* PACKAGE GTCRAX   !" 書式つき->gtool3軸ファイル
************************************************************************
      PROGRAM GTCRAX
*
#ifdef SYS_IBMS
      INCLUDE    (GTSINC)
      INCLUDE    (GZSIZE)
#else
#include         "gtsinc.F"
#include         "gzsize.F"
#endif
*
      PARAMETER  ( IMISS = -999 )
      PARAMETER  ( IMAXD = 1025 )
      REAL       XP( IMAXD )
      REAL       YP( IMAXD )
      REAL       ZP( IMAXD )
      REAL       XW( IMAXD )
*
      CHARACTER  X    *(NFILN)
      CHARACTER  Y    *(NFILN)
      CHARACTER  Z    *(NFILN)
      DATA       X,Y,Z / 3*' ' /
      CHARACTER  TX   *(NCC)
      CHARACTER  TY   *(NCC)
      CHARACTER  TZ   *(NCC)
      DATA       TX,TY,TZ / 3*' ' /
      LOGICAL    INVX
      LOGICAL    INVY
      LOGICAL    INVZ
      DATA       INVX, INVY, INVZ / 3*.FALSE. /
      REAL       XCYCL
      REAL       YCYCL
      REAL       ZCYCL
      DATA       XCYCL, YCYCL, ZCYCL / 3*0. /
      CHARACTER  HFILE( 1 )        *(NFILN)
      DATA       HFILE / '-' /
      DATA       IFILE / 50 /
      DATA       JFILE / 60 /
      LOGICAL    HELP
      DATA       HELP   / .FALSE. /
*
      NAMELIST  /OPTION/ X, Y, Z, TX, TY, TZ, INVX, INVY, INVZ,
     &                   XCYCL, YCYCL, ZCYCL, HFILE, HELP
*
      CALL OPTARG ( 91, 'OPTION', 'HFILE', NOPT, NFILE )
      READ (91,OPTION,IOSTAT=IOS)
      CLOSE(91)
      IF ( IOS.NE.0 .OR. HELP ) THEN
         WRITE(6,OPTION)
         STOP
      ENDIF
*
      CALL GTOPEN
*
      IF ( HFILE(1) .EQ. '-' ) THEN
         IFILE = 5
      ELSE
         OPEN ( IFILE, FILE=HFILE(1), 
     &          ACCESS='SEQUENTIAL',FORM='FORMATTED' )
      ENDIF
*
      CALL GTPGET ( 'MISS', VMISS )
      CALL RSET0  ( XP, IMAXD, 1, VMISS )
      CALL RSET0  ( YP, IMAXD, 1, VMISS )
      CALL RSET0  ( ZP, IMAXD, 1, VMISS )
*
      IXSTR = IMISS
      IYSTR = IMISS
      IZSTR = IMISS
      IXEND = IMISS
      IYEND = IMISS
      IZEND = IMISS
      IXDIM = 0
      IYDIM = 0
      IZDIM = 0
*
      II = 0
 2100 CONTINUE
         II = II + 1
*
         CALL RDTXTL
     I            ( IFILE ,
     M              X     , Y     , Z     ,
     M              IXSTR , IYSTR , IZSTR ,
     M              IXEND , IYEND , IZEND ,
     M              IXDIM , IYDIM , IZDIM ,
     M              XP    , YP    , ZP    , IMAXD-1, 
     O              IEOD                             )
*
         IF ( IEOD .EQ. 0 ) THEN
      GOTO 2100            
         ENDIF
*

      IF ( X .NE. ' ' ) THEN
         CALL    WRTAXS
     I         ( X     , TX    , XCYCL  , INVX   , 
     M           IXSTR , IXEND , IXDIM  , XP     , XW     )
      ENDIF
      IF ( Y .NE. ' ' ) THEN
         CALL    WRTAXS
     I         ( Y     , TY    , YCYCL  , INVY   , 
     M           IYSTR , IYEND , IYDIM  , YP     , XW     )
      ENDIF
      IF ( Z .NE. ' ' ) THEN
         CALL    WRTAXS
     I         ( Z     , TZ    , ZCYCL  , INVZ   , 
     M           IZSTR , IZEND , IZDIM  , ZP     , XW     )
      ENDIF
*
      STOP
      END
***********************************************************************
      SUBROUTINE WRTAXS
     I         ( HX    , HTX   , XCYCL  , OINVX  ,
     M           IXSTR , IXEND , IXDIM  , XP     , XW      )
*
      CHARACTER  HX  *(*)
      CHARACTER  HTX *(*)
      REAL       XCYCL
      LOGICAL    OINVX
      INTEGER    IXSTR, IXEND
      REAL       XP ( * )
      REAL       XW ( * )
*
#ifdef SYS_IBMS
      INCLUDE    (GZSIZE)
#else
#include         "gzsize.F"
#endif
*
      PARAMETER  ( IMISS = -999 )
      CHARACTER  HHEAD ( NDC )*(NCC)
      CHARACTER  HTYPE  *(NCC)
      CHARACTER  HTYPW  *(NCC)
      CHARACTER  HFILE  *(NFILN)
      CHARACTER  HAXF   *(NFILN)
*
      IF ( IXSTR .EQ. IMISS ) THEN
         IF ( IXEND .EQ. IMISS ) THEN
            IXSTR = 1
            IXEND = IXDIM
         ELSE
            IXSTR = IXEND-IXDIM+1
         ENDIF
      ELSE IF ( IXEND .EQ. IMISS ) THEN
         IXEND = IXSTR+IXDIM-1
      ENDIF
      IF ( IXEND-IXSTR+1 .NE. IXDIM ) THEN
         CALL MSGDMP('W','GTCRAX','MISMATCH IXDIM' )
      ENDIF
*
      IF ( OINVX ) THEN
         DO 1100 I = 1, IXDIM
            XW(I) = XP(IXDIM+1-I)
 1100    CONTINUE 
         DO 1110 I = 1, IXDIM
            XP(I) = XW(I)
 1110    CONTINUE 
      ENDIF
*
      DO 2100 I = 2, IXDIM-1
         XW(I) = ABS(XP(I+1)-XP(I-1))/2.
 2100 CONTINUE 
*
      IF ( XCYCL .NE. 0. ) THEN
         HTYPE = 'CAXLOC'
         HTYPW = 'CAXWGT'
         IXDIM = IXDIM + 1
         IXEND = IXEND + 1
         XP(IXDIM)   = XP(1)+XCYCL
         XW(1)       = ABS(XP(2)+XCYCL-XP(IXDIM-1))/2.
         XW(IXDIM-1) = ABS(XP(IXDIM)-XP(IXDIM-2))/2.
         XW(IXDIM)   = XW(1)
      ELSE
         HTYPE = 'AXLOC'
         HTYPW = 'AXWGT'
         XW(1)       = ABS(XP(2)-XP(1))/2.
         XW(IXDIM)   = ABS(XP(IXDIM)-XP(IXDIM-1))/2.
      ENDIF
*
      CALL GTPGET ( 'MISS', VMISS )
      CALL GTSIZE ( HHEAD , IMAXD )
      CALL    GHPACA
     O      ( HHEAD   ,
     I        HTYPE   , HX    ,
     I        HTX     , HTX   ,
     I        0       ,
     I        'UR4'   , VMISS ,
     I        VMISS   , VMISS , VMISS , VMISS , 1    )
      CALL    GHPSET( HHEAD, 'ASTR1', IXSTR )
      CALL    GHPSET( HHEAD, 'AEND1', IXEND )
*
      CALL GTPGET( 'WFILE', IFILW )
      CALL GTCGET( 'FAXLOC1', HAXF  )
      NHF   = LENC( HAXF )
      HFILE = HAXF(1:NHF)//HX
*
      CALL GFWOPN
     M      ( IFILW ,
     I        HFILE   )
      CALL GFWRIT
     O      ( HHEAD , XP  ,
     I        IFILW , 1   , 0             )
      CALL GFCLSE ( IFILW )
* 
      CALL GTCGET( 'FAXWGT1', HAXF  )
      NHF   = LENC( HAXF )
      HFILE = HAXF(1:NHF)//HX
      CALL GHCSET( HHEAD,'DSET', HTYPW )
* 
      CALL GFWOPN
     M      ( IFILW ,
     I        HFILE   )
      CALL GFWRIT
     O      ( HHEAD , XW  ,
     I        IFILW , 0   , 0             )
      CALL GFCLSE ( IFILW )
*
      RETURN
      END
***********************************************************************
      SUBROUTINE RDTXTL
     I         ( IFILE ,
     M           HX    , HY    , HZ     ,
     M           IXSTR , IYSTR , IZSTR ,
     M           IXEND , IYEND , IZEND ,
     M           IXDIM , IYDIM , IZDIM ,
     M           XP    , YP    , ZP    , IMAXD , 
     O           IEOD                            )
*
      INTEGER    IFILE
      CHARACTER  HX *(*)
      CHARACTER  HY *(*)
      CHARACTER  HZ *(*)
      REAL       XP ( * ), YP ( * ), ZP ( * )
*
#ifdef SYS_IBMS
      INCLUDE    (GZSIZE)
#else
#include         "gzsize.F"
#endif
      PARAMETER (NBUF=255)
      CHARACTER  HBUF*(NBUF), HXX*(NBUF)
      CHARACTER  HP*(NCC), HV*(NCC)
      LOGICAL    OFIRST
      DATA       OFIRST / .TRUE. /
      LOGICAL    LCHRN
      SAVE
*
      IF ( OFIRST ) THEN
         OFIRST = .FALSE.
  100    CONTINUE 
         READ ( IFILE,'(A)',IOSTAT=IEOS ) HBUF
         IF ( IEOS .NE. 0 ) THEN
            IEOD = 1
            RETURN
         ENDIF
         IF ( HBUF(1:1) .EQ. '#' ) THEN
            GOTO 100
         ENDIF
      ENDIF
*
      IDX = 0
*
 1100 CONTINUE
*
         IL   = LENB(HBUF)
         LENH = LEN(HBUF)
         IF ( .NOT.LCHRN(HBUF(IL+1:IL+1)) ) THEN
*
            IC = INDEX(HBUF,':')
            IF ( IC.GT.IL .AND. IC.LT.LENH ) THEN
               HP  = HBUF(IL+1:IC-1)
               ILX = LENB(HBUF(IC+1:LENH))+IC
               HV  = HBUF(ILX+1:LENH)
               IF      ( HP .EQ. 'AITM1' ) THEN
                  HX = HV
               ELSE IF ( HP .EQ. 'AITM2' ) THEN
                  HY = HV
               ELSE IF ( HP .EQ. 'AITM3' ) THEN
                  HZ = HV
               ELSE IF ( HP .EQ. 'ASTR1' ) THEN
                  CALL CRADJ(HV)
                  IF (HV.NE.' ') READ(HV,'(I16)') IXSTR
               ELSE IF ( HP .EQ. 'ASTR2' ) THEN
                  CALL CRADJ(HV)
                  IF (HV.NE.' ') READ(HV,'(I16)') IYSTR
               ELSE IF ( HP .EQ. 'ASTR3' ) THEN
                  CALL CRADJ(HV)
                  IF (HV.NE.' ') READ(HV,'(I16)') IZSTR
               ELSE IF ( HP .EQ. 'AEND1' ) THEN
                  CALL CRADJ(HV)
                  IF (HV.NE.' ') READ(HV,'(I16)') IXEND
               ELSE IF ( HP .EQ. 'AEND2' ) THEN
                  CALL CRADJ(HV)
                  IF (HV.NE.' ') READ(HV,'(I16)') IYEND
               ELSE IF ( HP .EQ. 'AEND3' ) THEN
                  CALL CRADJ(HV)
                  IF (HV.NE.' ') READ(HV,'(I16)') IZEND
               ENDIF
            ENDIF
*
 1200       CONTINUE 
               READ ( IFILE,'(A)',IOSTAT=IEOS ) HBUF
               IF ( IEOS .NE. 0 ) THEN
                  IEOD = 1
                  RETURN
               ENDIF
               IF ( HBUF(1:1) .EQ. '#' ) THEN
                  GOTO 1200
               ENDIF
*
      GOTO 1100
         ENDIF
*
 2100 CONTINUE
*
         IL   = LENB(HBUF)
         LENH = LEN(HBUF)
         IF ( LCHRN(HBUF(IL+1:IL+1)) ) THEN
            HXX=HBUF(IL+1:LENH)
*
            IF ( HX .EQ. ' ' ) THEN
               IF ( HY .EQ. ' ' ) THEN
                  IF ( IEODZ .NE. 0 ) THEN
                     ZPZ = 1.
                  ELSE
                     READ (HXX,*) ZPZ
                  ENDIF
               ELSE
                  IF ( HZ .EQ. ' ' ) THEN
                     READ (HXX,*) YPZ
                  ELSE
                     READ (HXX,*) YPZ, ZPZ
                  ENDIF
               ENDIF
            ELSE IF ( HY .EQ. ' ' ) THEN
               IF ( HZ .EQ. ' ' ) THEN
                  READ (HXX,*) XPZ
               ELSE
                  READ (HXX,*) XPZ, ZPZ
               ENDIF
            ELSE IF ( HZ .EQ. ' ' ) THEN
               READ (HXX,*) XPZ, YPZ
            ELSE
               READ (HXX,*) XPZ, YPZ, ZPZ
            ENDIF
*
            IF ( HX .NE. ' ' ) THEN
               CALL SETVAL( XPZ, IMAXD, XP, IXDIM )
            ENDIF
            IF ( HY .NE. ' ' ) THEN
               CALL SETVAL( YPZ, IMAXD, YP, IYDIM )
            ENDIF
            IF ( HZ .NE. ' ' ) THEN
               CALL SETVAL( ZPZ, IMAXD, ZP, IZDIM )
            ENDIF
*
 2200       CONTINUE 
               READ ( IFILE,'(A)',END=9000 ) HBUF
               IF ( HBUF(1:1) .EQ. '#' ) THEN
                  GOTO 2200
               ENDIF
*
      GOTO 2100
         ELSE
            IEOD = 0
            RETURN
         ENDIF
*
 9000 CONTINUE
      HBUF  = 'END_OF_FILE' 
      IEOD  = 0
*
      RETURN
      END
****************************************************************
      SUBROUTINE SETVAL
     I         ( X     , IMAXD  ,
     M           XP    , IXDIM    )
*
      REAL       X
      REAL       XP  ( IMAXD )
      INTEGER    IXDIM
*
      IX = INDXRF(XP,IXDIM,1,X)
      IF ( IX .EQ. 0 ) THEN
         IF ( IXDIM .EQ. 0 ) THEN
            IX = 1
         ELSE
            IX = IBLKLE(XP,IXDIM,X)
         ENDIF
         DO 2310 IXX = MIN(IXDIM,IMAXD-1), IX, -1
            XP(IXX+1) = XP(IXX)
 2310    CONTINUE 
         XP(IX) = X
         IF ( IXDIM .GE. IMAXD ) THEN
            CALL MSGDMP('W','SETVAL','TOO LARGE IXDIM' )
         ENDIF
         IXDIM = MIN(IXDIM+1,IMAXD)
      ENDIF
*
      RETURN
      END
********************************************************************
      LOGICAL FUNCTION   LCHRN(C)
      CHARACTER  C
      LOGICAL    LCHRD
*
      LCHRN = LCHRD(C) .OR. (C.EQ.'-') .OR. (C.EQ.'.')
*
      RETURN
      END


