* PACKAGE GTINTERP !" ³Ê»ÒÊÑ´¹ *********************************************************************** PROGRAM GTINTRP * #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 IFILP / 51 / DATA JFILE / 60 / * CHARACTER X *(NCC) CHARACTER Y *(NCC) CHARACTER Z *(NCC) DATA X,Y,Z / 3*' ' / CHARACTER OUT *(NFILN) DATA OUT / '$GTTMPDIR/gtool.out' / LOGICAL APND DATA APND / .FALSE. / LOGICAL MISOUT DATA MISOUT / .TRUE. / 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/ X, Y, Z, OUT, APND, MISOUT, & 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 SETCOR ( X, Y, Z ) CALL SETMIS ( MISOUT ) * 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 ( * ) * CHARACTER HCORX1 *(*) CHARACTER HCORY1 *(*) CHARACTER HCORZ1 *(*) * #ifdef SYS_IBMS INCLUDE (GZSIZE) #else #include "gzsize.F" #endif CHARACTER HXP ( NDC )*(NCC) CHARACTER HYP ( NDC )*(NCC) CHARACTER HZP ( NDC )*(NCC) PARAMETER ( IMAXD = 1024 ) REAL XS ( IMAXD ), XP( IMAXD ) REAL YS ( IMAXD ), YP( IMAXD ) REAL ZS ( IMAXD ), ZP( IMAXD ) CHARACTER HCORDX *(NCC) CHARACTER HCORDY *(NCC) CHARACTER HCORDZ *(NCC) 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 GTSIZE ( HXP , IMAXD ) CALL GUQAXC I ( HCORDX, 'LOC', O HXP , XP , CYCLE , IMAXP , IEOD ) * CALL GUQAXQ I ( HDS , 2 , 'LOC' , O YS , YCYCL , IYDIM , IEOD , D IMAXD ) CALL GTSIZE ( HYP , IMAXD ) CALL GUQAXC I ( HCORDY, 'LOC', O HYP , YP , CYCLE , JMAXP , IEOD ) * CALL GUQAXQ I ( HDS , 3 , 'LOC' , O ZS , ZCYCL , IZDIM , IEOD , D IMAXD ) CALL GTSIZE ( HZP , IMAXD ) CALL GUQAXC I ( HCORDZ, 'LOC', O HZP , ZP , CYCLE , KMAXP , IEOD ) * CALL INTR3 I ( DS , XS , YS , ZS , I IMAX , JMAX , KMAX , I XCYCL, YCYCL, ZCYCL, I XP , YP , ZP , I IMAXP, JMAXP, KMAXP, O DP ) * CALL GHCSET( HDP, 'AITM1', HCORDX ) CALL GHPSET( HDP, 'ASTR1', 1 ) CALL GHPSET( HDP, 'AEND1', IMAXP ) * CALL GHCSET( HDP, 'AITM2', HCORDY ) CALL GHPSET( HDP, 'ASTR2', 1 ) CALL GHPSET( HDP, 'AEND2', JMAXP ) * CALL GHCSET( HDP, 'AITM3', HCORDZ ) CALL GHPSET( HDP, 'ASTR3', 1 ) CALL GHPSET( HDP, 'AEND3', KMAXP ) * RETURN *===================================================================== ENTRY SETCOR I ( HCORX1, HCORY1, HCORZ1 ) HCORDX = HCORX1 HCORDY = HCORY1 HCORDZ = HCORZ1 RETURN END *********************************************************************** SUBROUTINE INTR3 I ( DS , XS , YS , ZS , I NXS , NYS , NZS , I XCYCL, YCYCL, ZCYCL, I XP , YP , ZP , I NXP , NYP , NZP , O DP ) * REAL DS ( NXS, NYS, NZS ) REAL XS ( NXS ) REAL YS ( NYS ) REAL ZS ( NZS ) REAL XP ( NXP ) REAL YP ( NYP ) REAL ZP ( NZP ) REAL DP ( NXP, NYP, NZP ) * LOGICAL OMISOZ LOGICAL OMISOU DATA OMISOU / .TRUE. / PARAMETER ( NDIM = 1025 ) INTEGER I0 ( NDIM ), I1 ( NDIM ) INTEGER J0 ( NDIM ), J1 ( NDIM ) INTEGER K0 ( NDIM ), K1 ( NDIM ) REAL DI ( NDIM ) REAL DJ ( NDIM ) REAL DK ( NDIM ) * IF ( MAX( NXP, NYP, NZP ) .GT. NDIM ) THEN CALL MSGDMP( 'E','INTR3', ' TOO SMALL WORK AREA: NDIM' ) ENDIF * CALL GLPGET( 'RMISS', VMISS ) * CALL GETRNG I ( XS , NXS , XCYCL , I XP , NXP , O I0 , I1 , DI ) * CALL GETRNG I ( YS , NYS , YCYCL , I YP , NYP , O J0 , J1 , DJ ) * CALL GETRNG I ( ZS , NZS , ZCYCL , I ZP , NZP , O K0 , K1 , DK ) * DO 4100 KP = 1, NZP DO 4100 JP = 1, NYP DO 4100 IP = 1, NXP * DX = DI(IP) DY = DJ(JP) DZ = DK(KP) * DX1 = 1.-DX DY1 = 1.-DY DZ1 = 1.-DZ * IF ( OMISOU ) THEN IF ( (DX .GT. 1.).OR.(DY .GT. 1.) & .OR.(DZ .GT. 1.) ) THEN DP(IP,JP,KP) = VMISS GOTO 4100 ENDIF ENDIF * SP = 0. SD = 0. IF ( DS(I0(IP),J0(JP),K0(KP)) .NE. VMISS ) THEN SP = SP + DS(I0(IP),J0(JP),K0(KP))* DX1*DY1*DZ1 SD = SD + DX1*DY1*DZ1 ENDIF IF ( DS(I1(IP),J0(JP),K0(KP)) .NE. VMISS ) THEN SP = SP + DS(I1(IP),J0(JP),K0(KP))* DX *DY1*DZ1 SD = SD + DX *DY1*DZ1 ENDIF IF ( DS(I0(IP),J1(JP),K0(KP)) .NE. VMISS ) THEN SP = SP + DS(I0(IP),J1(JP),K0(KP))* DX1*DY *DZ1 SD = SD + DX1*DY *DZ1 ENDIF IF ( DS(I1(IP),J1(JP),K0(KP)) .NE. VMISS ) THEN SP = SP + DS(I1(IP),J1(JP),K0(KP))* DX *DY *DZ1 SD = SD + DX *DY *DZ1 ENDIF IF ( DS(I0(IP),J0(JP),K1(KP)) .NE. VMISS ) THEN SP = SP + DS(I0(IP),J0(JP),K1(KP))* DX1*DY1*DZ SD = SD + DX1*DY1*DZ ENDIF IF ( DS(I1(IP),J0(JP),K1(KP)) .NE. VMISS ) THEN SP = SP + DS(I1(IP),J0(JP),K1(KP))* DX *DY1*DZ SD = SD + DX *DY1*DZ ENDIF IF ( DS(I0(IP),J1(JP),K1(KP)) .NE. VMISS ) THEN SP = SP + DS(I0(IP),J1(JP),K1(KP))* DX1*DY *DZ SD = SD + DX1*DY *DZ ENDIF IF ( DS(I1(IP),J1(JP),K1(KP)) .NE. VMISS ) THEN SP = SP + DS(I1(IP),J1(JP),K1(KP))* DX *DY *DZ SD = SD + DX *DY *DZ ENDIF IF ( SD .GT. 0. ) THEN DP(IP,JP,KP) = SP/SD ELSE DP(IP,JP,KP) = VMISS ENDIF * 4100 CONTINUE * RETURN *=============================================================== ENTRY SETMIS I ( OMISOZ ) OMISOU = OMISOZ RETURN END **************************************************************** SUBROUTINE GETRNG I ( XS , NXS , XCYCL , I XP , NXP , O I0 , I1 , DX ) * REAL XS ( NXS ) REAL XCYCL REAL XP ( NXP ) INTEGER I0 ( NXP ) INTEGER I1 ( NXP ) REAL DX ( NXP ) * IF ( XCYCL .NE. 0. ) THEN NCY = 1 ELSE NCY = 0 ENDIF * IF ( NXS .EQ. 1 ) THEN DO 100 IP = 1, NXP I0(IP) = 1 I1(IP) = 1 DX(IP) = 0. 100 CONTINUE * RETURN ENDIF DO 1100 IP = 1, NXP I0 ( IP ) = 0 DO 1110 IX = 1, NXS DO 1110 ICY = -NCY, NCY * IF ( IX .NE. NXS ) THEN IXP = IX + 1 DA = XS(IXP) - XS(IX) DD = ( XP(IP) - ( XS(IX) + ICY*XCYCL ) ) / DA ELSE IF ( XCYCL .NE. 0. ) THEN IXP = 1 DA = XS(1)+XCYCL - XS(IX) DD = ( XP(IP) - ( XS(IX) + ICY*XCYCL ) ) / DA ELSE GOTO 1110 ENDIF * IF ( DD .GE. 0. .AND. DD .LE. 1. ) THEN I0(IP) = IX I1(IP) = IXP DX(IP) = DD ELSE IF ( (IX .EQ. 1) .AND. (ICY .EQ. -NCY ) & .AND. (DD .LT. 0. ) ) THEN I0(IP) = 1 I1(IP) = 1 DX(IP) = 2. ELSE IF ( (IX .EQ. NXS-1) .AND. (ICY .EQ. NCY ) & .AND. (DD .GT. 1. ) ) THEN I0(IP) = NXS I1(IP) = NXS DX(IP) = 2. ENDIF 1110 CONTINUE IF ( I0(IP) .EQ. 0 ) WRITE (6,*) 'ERROR I0', IP * 1100 CONTINUE * RETURN END