* PACKAGE  GTIMIS !" ท็ยปรอสไดึ
***********************************************************************
      PROGRAM GTIMIS
*
#ifdef SYS_IBMS
      INCLUDE    (GTSINC)
      INCLUDE    (GZSIZE)
#else
#include         "gtsinc.F"
#include         "gzsize.F"
#endif
      COMMON     /GMWORK/ MWORK
      REAL       MWORK  ( IJKDIM )
*
      CHARACTER  HHEAD( NDC )*(NCC)
      REAL       GDATA( IJKDIM )
*
      CHARACTER  HFILE( 1 ) *(NFILN)
      DATA       HFILE   / '$GTTMPDIR/gtool.out' /
      DATA       IFILE / 50 /
      DATA       JFILE / 60 /
*
      REAL       WX
      REAL       WY
      REAL       WZ
      DATA       WX,WY,WZ  / 3* 1.0 /
      CHARACTER  OUT     *(NFILN)
      DATA       OUT    / '$GTTMPDIR/gtool.out' /
      LOGICAL    APND
      DATA       APND   / .FALSE. /
      CHARACTER  ITEM   *(NCC)
      CHARACTER  UNIT   *(NCC)
      CHARACTER  TITLE  *(NCC*2)
      CHARACTER  DSET   *(NCC)
      CHARACTER  EDIT   *(NCC)
      CHARACTER  ETTL   *(NCC)
      DATA       ITEM, UNIT, TITLE, DSET, EDIT, ETTL / 6*' '/
      LOGICAL    GRESET
      DATA       GRESET / .FALSE. /
      LOGICAL    HELP
      DATA       HELP   / .FALSE. /
*
      EXTERNAL   INTERP
*     
      NAMELIST  /OPTION/ WX, WY, WZ, OUT, APND,
     &                   ITEM, UNIT, TITLE, DSET, EDIT, ETTL, GRESET,
     &                   HELP, HFILE
*
      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 GMSIZE ( IJKDIM  )
*
      CALL GURNTF ( HFILE( 1 ), OUT  , '$GTTMPDIR/gtool.in' )
*
      CALL GFROPN ( IFILE , HFILE( 1 ) )
      CALL GFOOPN ( JFILE ,  OUT , APND )
*
      CALL GUNENV( OUT,'.',.FALSE. )
      IL=LENC(OUT)
      WRITE (6,*) 'output='//OUT(1:IL)
*
      CALL  SETWGT ( WX, WY, WZ )
*
 1100 CONTINUE
         CALL   GFREAD
     O        ( HHEAD , GDATA , IEOD  ,
     I          IFILE , 1               )
*
         IF ( MAX(IEOD,IEODP) .EQ.0 ) THEN
            CALL GMCAL1
     I         ( INTERP,
     M           HHEAD , GDATA ,
     I           EDIT  , ETTL  )
*
            IF ( ITEM .NE. ' ' ) THEN
               CALL GHCSET( HHEAD , 'ITEM', ITEM )
            ENDIF
            IF ( UNIT .NE. ' ' ) THEN
               CALL GHCSET( HHEAD , 'UNIT', UNIT )
            ENDIF
            IF ( TITLE .NE. ' ' ) THEN
               CALL GHCSTS( HHEAD , 'TITL', TITLE )
            ENDIF
            IF ( DSET .NE. ' ' ) THEN
               CALL GHCSET( HHEAD , 'DSET', DSET )
            ENDIF
            IF ( GRESET ) THEN
               CALL GHRSGP( HHEAD  )
            ENDIF
*
            CALL  GFWRIT
     I                 ( HHEAD , GDATA ,
     I                   JFILE , 1     , 0       )
*
      GOTO 1100
         ENDIF
*
      STOP
      END
********************************************************************
      SUBROUTINE INTERP
     I         ( HDS   , DS     ,
     O           HDP   , DP    ,
     D           IMAX  , JMAX  , KMAX  )
*
      CHARACTER  HDS ( * )*(*)
      REAL       DS ( * )
      CHARACTER  HDP ( * )*(*)
      REAL       DP ( * )
*
#ifdef SYS_IBMS
      INCLUDE    (GZSIZE)
#else
#include         "gzsize.F"
#endif
      PARAMETER  ( IMAXD = 1024 )
      REAL       XS ( IMAXD )
      REAL       YS ( IMAXD )
      REAL       ZS ( IMAXD )
      REAL       XCYCL, YCYCL, ZCYCL
*
      IF ( MAX(IMAX,JMAX,KMAX) .GT. IMAXD ) THEN
         CALL MSGDMP( 'E','INTERP','WORK AREA TOO SMALL' )
      ENDIF
*
      CALL GUSMIS( HDS )
* 
      CALL GUQAXQ
     I            ( HDS   , 1     , 'LOC' ,
     O              XS    , XCYCL , IXDIM , IEOD  , 
     D              IMAXD                 )
*
      CALL GUQAXQ
     I            ( HDS   , 2     , 'LOC' ,
     O              YS    , YCYCL , IYDIM , IEOD  , 
     D              IMAXD                 )
*
      CALL GUQAXQ
     I            ( HDS   , 3     , 'LOC' ,
     O              ZS    , ZCYCL , IZDIM , IEOD  , 
     D              IMAXD                 )
*
      CALL INTR3
     I           ( DS  , XS   , YS   , ZS   ,
     I                   IMAX , JMAX , KMAX ,
     I                   XCYCL, YCYCL, ZCYCL,
     I                   WX   , WY   , WZ   ,
     O             DP                          )
*
      RETURN
*===============================================================
      ENTRY      SETWGT
     I         ( WX1, WY1, WZ1 )
      WX = WX1
      WY = WY1
      WZ = WZ1
      END
****************************************************************
      SUBROUTINE INTR3
     I         ( DS  , XS   , YS   , ZS   ,
     I                 NXS  , NYS  , NZS  ,
     I                 XCYCL, YCYCL, ZCYCL,
     I                 WX   , WY   , WZ   ,
     O           DP                          )
*
      REAL       DS  ( NXS, NYS, NZS )
      REAL       XS  ( NXS )
      REAL       YS  ( NYS )
      REAL       ZS  ( NZS )
      REAL       DP  ( NXS, NYS, NZS )
      EXTERNAL   IMOD
*
      CALL       GLPGET( 'RMISS', VMISS )
      ICOUNT = 0
*
      DO 4100 K = 1, NZS
         DO 4100 J = 1, NYS
            DO 4100 I = 1, NXS
*
               IF ( DS(I,J,K) .EQ. VMISS ) THEN
*
                  S = 0.
                  W = 0.
*
                  IF ( WX .NE. 0. ) THEN
                     IF ( XCYCL .NE. 0. ) THEN
                        IME = I-NXS
                        IPE = I+NXS
                     ELSE
                        IME = 1
                        IPE = NXS
                     ENDIF
                     DO 5100 II = I-1, IME, -1
                        III = IMOD(II-1,NXS)+1
                        IF ( DS(III,J,K) .NE. VMISS ) THEN
                           IF ( II .LE. 0 ) THEN
                              WXM = 1./(XS(I)-XS(III)+XCYCL)**2
                           ELSE
                              WXM = 1./(XS(I)-XS(III))**2
                           ENDIF
                           S = S + WX*WXM*DS(III,J,K)
                           W = W + WX*WXM
                           GOTO 5110
                        ENDIF
 5100                CONTINUE 
 5110                CONTINUE 
                     DO 5200 II = I+1, IPE
                        III = IMOD(II-1,NXS)+1
                        IF ( DS(III,J,K) .NE. VMISS ) THEN
                           IF ( II .GT. NXS ) THEN
                              WXP = 1./(XS(III)-XS(I)+XCYCL)**2
                           ELSE
                              WXP = 1./(XS(III)-XS(I))**2
                           ENDIF
                           S = S + WX*WXP*DS(III,J,K)
                           W = W + WX*WXP
                           GOTO 5210
                        ENDIF
 5200                CONTINUE 
 5210                CONTINUE 
                  ENDIF
*
                  IF ( WY .NE. 0. ) THEN
                     IF ( YCYCL .NE. 0. ) THEN
                        JME = J-NYS
                        JPE = J+NYS
                     ELSE
                        JME = 1
                        JPE = NYS
                     ENDIF
                     DO 6100 JJ = J-1, JME, -1
                        JJJ = IMOD(JJ-1,NYS)+1
                        IF ( DS(I,JJJ,K) .NE. VMISS ) THEN
                           IF ( JJ .LE. 0 ) THEN
                              WYM = 1./(YS(J)-YS(JJJ)+YCYCL)**2
                           ELSE
                              WYM = 1./(YS(J)-YS(JJJ))**2
                           ENDIF
                           S = S + WY*WYM*DS(I,JJJ,K)
                           W = W + WY*WYM
                           GOTO 6110
                        ENDIF
 6100                CONTINUE 
 6110                CONTINUE 
                     DO 6200 JJ = J+1, JPE
                        JJJ = IMOD(JJ-1,NYS)+1
                        IF ( DS(I,JJJ,K) .NE. VMISS ) THEN
                           IF ( JJ .GT. NYS ) THEN
                              WYP = 1./(YS(JJJ)-YS(J)+YCYCL)**2
                           ELSE
                              WYP = 1./(YS(JJJ)-YS(J))**2
                           ENDIF
                           S = S + WY*WYP*DS(I,JJJ,K)
                           W = W + WY*WYP
                           GOTO 6210
                        ENDIF
 6200                CONTINUE 
 6210                CONTINUE 
                  ENDIF
*
                  IF ( WZ .NE. 0. ) THEN
                     IF ( ZCYCL .NE. 0. ) THEN
                        KME = K-NZS
                        KPE = K+NZS
                     ELSE
                        KME = 1
                        KPE = NZS
                     ENDIF
                     DO 7100 KK = K-1, KME, -1
                        KKK = IMOD(KK-1,NZS)+1
                        IF ( DS(I,J,KKK) .NE. VMISS ) THEN
                           IF ( KK .LE. 0 ) THEN
                              WZM = 1./(ZS(K)-ZS(KKK)+ZCYCL)**2
                           ELSE
                              WZM = 1./(ZS(K)-ZS(KKK))**2
                           ENDIF
                           S = S + WZ*WZM*DS(I,J,KKK)
                           W = W + WZ*WZM
                           GOTO 7110
                        ENDIF
 7100                CONTINUE 
 7110                CONTINUE 
                     DO 7200 KK = K+1, KPE
                        KKK = IMOD(KK-1,NZS)+1
                        IF ( DS(I,J,KKK) .NE. VMISS ) THEN
                           IF ( KK .GT. NZS ) THEN
                              WZP = 1./(ZS(KKK)-ZS(K)+ZCYCL)**2
                           ELSE
                              WZP = 1./(ZS(KKK)-ZS(K))**2
                           ENDIF
                           S = S + WZ*WZP*DS(I,J,KKK)
                           W = W + WZ*WZP
                           GOTO 7210
                        ENDIF
 7200                CONTINUE 
 7210                CONTINUE 
                  ENDIF
*
                  IF ( W .GT. 0. ) THEN
                     DP(I,J,K) = S/W
                  ELSE
                     DP(I,J,K) = VMISS
                     ICOUNT = ICOUNT + 1
                  ENDIF
*
               ELSE
                  DP(I,J,K) = DS(I,J,K)
               ENDIF
*
 4100 CONTINUE 
*
      IF ( ICOUNT .NE. 0 ) THEN
         CALL MSGDMP( 'W','GTIMIS','STILL MISSING VALUE' )
         WRITE (6,*) ICOUNT
      ENDIF
*
      RETURN
      END
