* PACKAGE GTCREATE   !" ½ñ¼°¤Ä¤­->gtool3
************************************************************************
      PROGRAM GTCRET
*
#ifdef SYS_IBMS
      INCLUDE    (GTSINC)
      INCLUDE    (GZSIZE)
#else
#include         "gtsinc.F"
#include         "gzsize.F"
#endif
*
      CHARACTER  HHEAD ( NDC )*(NCC)
      REAL       GDATA ( IJKDIM )
      CHARACTER  HDATE*(NCC)
      CHARACTER  HSIGN*(NCC)
*
      CHARACTER  HFILE( 1 )        *(NFILN)
      DATA       HFILE / '-' /
      DATA       IFILE / 50 /
      DATA       JFILE / 60 /
      LOGICAL    LOC
      DATA       LOC    / .FALSE. /
      CHARACTER  OUT    *(NFILN)
      DATA       OUT    / '$GTTMPDIR/gtool.out' /
      LOGICAL    APND
      DATA       APND   / .FALSE. /
      LOGICAL    HELP
      DATA       HELP   / .FALSE. /
*
      NAMELIST  /OPTION/ LOC, OUT, APND, 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
      CALL GTSIZE ( HHEAD , IJKDIM )
      CALL GHPCLR ( HHEAD )
      CALL GTPGET ( 'MISS', VMISS )
      CALL GHPSET ( HHEAD, 'FNUM', 1     )
      CALL GHPSET ( HHEAD, 'DNUM', 1     )
      CALL GHCSET ( HHEAD, 'UTIM', 'DAY' )
      CALL GHPSET ( HHEAD, 'TDUR', 1     )
      CALL GHPSET ( HHEAD, 'ASTR1', 0    )      
      CALL GHPSET ( HHEAD, 'AEND1', 0    )      
      CALL GHPSET ( HHEAD, 'ASTR2', 0    )      
      CALL GHPSET ( HHEAD, 'AEND2', 0    )      
      CALL GHPSET ( HHEAD, 'ASTR3', 0    )      
      CALL GHPSET ( HHEAD, 'AEND3', 0    )      
      CALL GHPSET ( HHEAD, 'MISS', VMISS )
      CALL GHPSET ( HHEAD, 'DMIN', VMISS )
      CALL GHPSET ( HHEAD, 'DMAX', VMISS )
      CALL GHPSET ( HHEAD, 'DIVS', VMISS )
      CALL GHPSET ( HHEAD, 'DIVL', VMISS )
      CALL GHPSET ( HHEAD, 'STYP', 1     )
      CALL GHCSET ( HHEAD, 'DFMT', 'UR4' )
      CALL GUQNOW ( HDATE )
      CALL GTCGET ( 'MYSIGN', HSIGN )
      CALL GHCSET ( HHEAD , 'CDATE' , HDATE )
      CALL GHCSET ( HHEAD , 'CSIGN' , HSIGN )
*
      CALL GURNTF ( HFILE( 1 ), OUT  , '$GTTMPDIR/gtool.in' )
*
      IF ( HFILE(1) .EQ. '-' ) THEN
         IFILE = 5
      ELSE
         OPEN ( IFILE, FILE=HFILE(1), 
     &          ACCESS='SEQUENTIAL',FORM='FORMATTED' )
      ENDIF
      CALL GFOOPN ( JFILE, OUT , APND )
*
      II = 0
 2100 CONTINUE
         II = II + 1
*
         IF ( LOC ) THEN
            CALL RDTXTL
     I            ( IFILE ,
     M              HHEAD ,
     O              GDATA , IEOD  )
         ELSE
            CALL RDTXT
     I            ( IFILE ,
     M              HHEAD ,
     O              GDATA , IEOD  )
         ENDIF
*
         IF ( IEOD .EQ. 0 ) THEN
            CALL GFWRIT
     I            ( HHEAD , GDATA ,
     I              JFILE , 1     , 0       )
      GOTO 2100            
         ENDIF
*
      STOP
      END
***********************************************************************
      SUBROUTINE RDTXT
     I         ( IFILE ,
     M           HHEAD ,
     O           GDATA, IEOD  )
*
      CHARACTER  HHEAD ( * )*(*)
      REAL       GDATA ( * )
*
      
#ifdef SYS_IBMS
      INCLUDE    (GZSIZE)
#else
#include         "gzsize.F"
#endif
      PARAMETER (NBUF=255)
      CHARACTER  HBUF*(NBUF), HXX*(NBUF)
      CHARACTER  HP*(NCC), HX*(NCC)
      CHARACTER  HFMT*(NCC)
      LOGICAL    OFIRST
      DATA       OFIRST / .TRUE. /
      LOGICAL    LCHRN
*
  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
*
      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
               HXX = HBUF(ILX+1:LENH)
               HX  = HXX
               IF ( HP .EQ. 'TITLE' ) THEN
                  CALL GHCSTS(HHEAD,'TITL',HXX)
               ELSE IF ( HP .NE. 'SIZE' ) THEN
                  CALL GHPINQ(HP,HFMT)
                  IF ( HFMT .NE. '(A)' ) THEN
                     CALL CRADJ(HX)
                  ENDIF
                  CALL GHCSET(HHEAD,HP,HX)
               ENDIF
            ENDIF
*
 1200       CONTINUE 
               READ ( IFILE,'(A)',END=9000 ) HBUF
            IF ( HBUF(1:1) .EQ. '#' ) THEN
               GOTO 1200
            ENDIF
*
      GOTO 1100
         ENDIF
*
      CALL GUQTSZ( HHEAD,ISIZE )
      CALL GHPSET( HHEAD, 'SIZE', ISIZE )
*
 2100 CONTINUE
*
         IL   = LENB(HBUF)
         LENH = LEN(HBUF)
         IF ( LCHRN(HBUF(IL+1:IL+1)) ) THEN
*
            IC = INDEX(HBUF,':')
            IF ( IC.GT.IL .AND. IC.LT.LENH ) THEN
               ILX = LENB (HBUF(IC+1:LENH))+IC
               HXX = HBUF(ILX+1:LENH)
            ELSE
               HXX=HBUF(IL+1:LENH)
            ENDIF
            IDX = IDX + 1
            READ (HXX,*) GDATA(IDX)
*
            IF ( IDX .EQ. ISIZE ) THEN
               IEOD = 0
               RETURN
            ENDIF
            ILN  = INDEX(HXX,' ')
            LENH = LEN(HXX)
            IF ( ILN .GT. 0 .AND. ILN .LT. LENH ) THEN
               HBUF = HXX(ILN+1:LENH)
      GOTO 2100
            ENDIF
*
         ELSE
            READ ( IFILE,'(A)',END=9000 ) HBUF
      GOTO 2100
*
         ENDIF
*
 9000 CONTINUE
      IF ( IDX .NE. 0 ) THEN
         CALL MSGDMP('W','RDTXT','UNEXPECTED EOF')
      ENDIF
      IEOD = 1
      RETURN
*
      END
********************************************************************
      LOGICAL FUNCTION   LCHRN(C)
      CHARACTER  C
      LOGICAL    LCHRD
*
      LCHRN = LCHRD(C) .OR. (C.EQ.'-') .OR. (C.EQ.'.')
*
      RETURN
      END
***********************************************************************
      SUBROUTINE RDTXTL
     I         ( IFILE ,
     M           HHEAD ,
     O           GDATA, IEOD  )
*
      CHARACTER  HHEAD ( * )*(*)
      REAL       GDATA ( * )
*
#ifdef SYS_IBMS
      INCLUDE    (GZSIZE)
#else
#include         "gzsize.F"
#endif
      PARAMETER (NBUF=255)
      CHARACTER  HBUF*(NBUF), HXX*(NBUF)
      CHARACTER  HP*(NCC), HX*(NCC)
      CHARACTER  HFMT*(NCC)
      LOGICAL    OFIRST
      DATA       OFIRST / .TRUE. /
      LOGICAL    LCHRN
      SAVE
*
      PARAMETER  ( IMAXD = 1024 )
      REAL       XP( IMAXD )
      REAL       YP( IMAXD )
      REAL       ZP( IMAXD )
*
      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
               HXX = HBUF(ILX+1:LENH)
               HX  = HXX
               IF ( HP .EQ. 'TITLE' ) THEN
                  CALL GHCSTS(HHEAD,'TITL',HXX)
               ELSE IF ( HP .NE. 'SIZE' ) THEN
                  CALL GHPINQ(HP,HFMT)
                  IF ( HFMT .NE. '(A)' ) THEN
                     CALL CRADJ(HX)
                  ENDIF
                  CALL GHCSET(HHEAD,HP,HX)
               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
*
      CALL GUQAXQ
     I            ( HHEAD , 1     , 'LOC' ,
     O              XP    , XCYCL , IXDIM , IEODX , 
     D              IMAXD                 )
      CALL GUQAXQ
     I            ( HHEAD , 2     , 'LOC' ,
     O              YP    , YCYCL , IYDIM , IEODY , 
     D              IMAXD                 )
      CALL GUQAXQ
     I            ( HHEAD , 3     , 'LOC' ,
     O              ZP    , ZCYCL , IZDIM , IEODZ , 
     D              IMAXD                 )
*
      CALL GHPGET ( HHEAD, 'MISS', VMISS )
      CALL RSET0  ( GDATA, IXDIM*IYDIM*IZDIM, 1, VMISS )
*
      CALL GUQSIZ
     I         ( HHEAD ,
     O           ISTRD , IENDD , IDIMD ,
     O           JSTRD , JENDD , JDIMD ,
     O           KSTRD , KENDD , KDIMD  )
      IF ( ISTRD .EQ. 0 .AND. IENDD .EQ. 0  ) THEN
         CALL GHPSET( HHEAD, 'ASTR1', 1     )
         CALL GHPSET( HHEAD, 'AEND1', IXDIM )
      ENDIF
      IF ( JSTRD .EQ. 0 .AND. JENDD .EQ. 0  ) THEN
         CALL GHPSET( HHEAD, 'ASTR2', 1     )
         CALL GHPSET( HHEAD, 'AEND2', IYDIM )
      ENDIF
      IF ( KSTRD .EQ. 0 .AND. KENDD .EQ. 0  ) THEN
         CALL GHPSET( HHEAD, 'ASTR3', 1     )
         CALL GHPSET( HHEAD, 'AEND3', IZDIM )
      ENDIF
*
      CALL GUQTSZ( HHEAD,ISIZE )
      CALL GHPSET( HHEAD, 'SIZE', ISIZE )
*
 2100 CONTINUE
*
         IL   = LENB(HBUF)
         LENH = LEN(HBUF)
         IF ( LCHRN(HBUF(IL+1:IL+1)) ) THEN
            HXX=HBUF(IL+1:LENH)
*
            IF ( IEODX .NE. 0 ) THEN
               IF ( IEODY .NE. 0 ) THEN
                  IF ( IEODZ .NE. 0 ) THEN
                     READ (HXX,*) GDZ
                  ELSE
                     READ (HXX,*) ZPZ, GDZ
                  ENDIF
               ELSE
                  IF ( IEODZ .NE. 0 ) THEN
                     READ (HXX,*) YPZ, GDZ
                  ELSE
                     READ (HXX,*) YPZ, ZPZ, GDZ
                  ENDIF
               ENDIF
            ELSE IF ( IEODY .NE. 0 ) THEN
               IF ( IEODZ .NE. 0 ) THEN
                  READ (HXX,*) XPZ, GDZ
               ELSE
                  READ (HXX,*) XPZ, ZPZ, GDZ
               ENDIF
            ELSE IF ( IEODZ .NE. 0 ) THEN
               READ (HXX,*) XPZ, YPZ, GDZ
            ELSE
               READ (HXX,*) XPZ, YPZ, ZPZ, GDZ
            ENDIF
*
            CALL NEARST ( XPZ, XP, IXDIM, XCYCL, IX )
            CALL NEARST ( YPZ, YP, IYDIM, YCYCL, IY )
            CALL NEARST ( ZPZ, ZP, IZDIM, ZCYCL, IZ )
*
            GDATA( ((IZ-1)*IYDIM+IY-1)*IXDIM+IX ) = GDZ
*
 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
      IEOD = 0
      HBUF = 'END_OF_FILE'
*
      RETURN
      END
****************************************************************
      SUBROUTINE NEARST
     I         ( X     , XP    , NXP   , XCYCL  ,
     O           IX                                )
*
      REAL       X
      REAL       XP  ( NXP )
      REAL       XCYCL
      INTEGER    IX
*
      IF ( NXS .EQ. 1 ) THEN
         IX = 1
         RETURN
      ENDIF
*
      DX = ABS(XP(1)-X)
      IX = 1
*
      DO 1100 IP = 1, NXP
         DXP = ABS(XP(IP)-X)
         IF ( XCYCL .NE. 0. ) THEN
            DXP = DXP-INT(DXP/ABS(XCYCL))*ABS(XCYCL)
         ENDIF
         IF ( DXP .LT. DX ) THEN
            DX = DXP 
            IX = IP
         ENDIF
 1100 CONTINUE 
*
      RETURN
      END


