SUBROUTINE RDDATA(IX,JX,KX,U,V,T,Q,W,PP,QC,QR,QI,QS,PS,TG,RNC,RNN, RDDATA.2 1 F, XMF,DMF,XLAT,XLON,DLAT,DLON,TMN,TER,XLND,SNOW, RDDATA.3 2 IUNIT,HEAD,IEND,IWR,IUNWR, 3 DUM3D,DUM2D,DUM3D_8,DUM2D_8,IEEE) RDDATA.4 C RDDATA.5 C IUNIT : unit number for reading RDDATA.6 C IUNWR : unit number for writing RDDATA.7 C HEAD : .TRUE. read all the data, .FALSE. only header record is read RDDATA.8 C IEND : flag to detect the EOF, IEND=1 EOF found. RDDATA.9 C IWR : IWR=1 write out the data, IWR=0 no write out completed. RDDATA.10 C RDDATA.11 C ----------------------------------------------------------------------- RDDATA.12 C RDDATA.13 C MIF : Array store integer variables information RDDATA.14 C MIFC: Character array describs the MIF array RDDATA.15 C MRF : Array store real variables information RDDATA.16 C MRFC: Character array describs the MRF array RDDATA.17 COMMON /HEADER/ MIF, MRF, MIFC, MRFC RDDATA.18 INTEGER MIF(1000,20) RDDATA.19 REAL MRF(1000,20) RDDATA.20 CHARACTER*80 MIFC(1000,20),MRFC(1000,20) RDDATA.21 INTEGER*8 MIF_8(1000,20) REAL*8 MRF_8(1000,20) C RDDATA.22 CHARACTER*8 ID RDDATA.23 REAL*8 DUM3D_8(IX,JX,KX),DUM2D_8(IX,JX) DIMENSION DUM3D(IX,JX,KX),DUM2D(IX,JX) RDDATA.24 LOGICAL HEAD RDDATA.25 C RDDATA.26 DIMENSION U(IX,JX,KX), V(IX,JX,KX), W(IX,JX,KX+1), T(IX,JX,KX), RDDATA.27 1 Q(IX,JX,KX),PP(IX,JX,KX),QC(IX,JX,KX), QR(IX,JX,KX), RDDATA.28 1 QI(IX,JX,KX),QS(IX,JX,KX), RDDATA.29 2 PS(IX,JX), TG(IX,JX), RNC(IX,JX), RNN(IX,JX), RDDATA.30 3 F(IX,JX), XMF(IX,JX), DMF(IX,JX),XLAT(IX,JX), RDDATA.31 4 XLON(IX,JX),DLAT(IX,JX),DLON(IX,JX), TMN(IX,JX), RDDATA.32 5 TER(IX,JX),XLND(IX,JX),SNOW(IX,JX) RDDATA.33 C RDDATA.34 PRINT *,'MM5 version 2 from Unit ',IUNIT,' IEEE=',IEEE MODS.3 PRINT *,' ' RDDATA.36 IF (IEEE.EQ.64) THEN READ(IUNIT,END=999) MIF_8,MRF_8,MIFC,MRFC do mm = 1,1000 do nn = 1,20 if (mif_8(mm,nn).gt.1e9) THEN print *,'Fixing mif_8(',mm,nn,'), it now is ', > MIF_8(mm,nn)/100 MIF(mm,nn)=MIF_8(mm,nn)/100 else MIF(mm,nn)=MIF_8(mm,nn) endif mrf(mm,nn) = mrf_8(mm,nn) end do end do ELSE READ(IUNIT,END=999) MIF,MRF,MIFC,MRFC RDDATA.37 ENDIF C IF (IWR.EQ.1) WRITE(IUNWR) MIF,MRF,MIFC,MRFC C RDDATA.38 IEND = 0 RDDATA.39 C RDDATA.40 C INDEX : output is generated by which program? RDDATA.41 C 1 TERRAIN RDDATA.42 C 2 DATAGRID RDDATA.43 C 3 RAWINS 3-D analysis RDDATA.44 C 4 RAWINS surface 4DDA RDDATA.45 C 5 MM5 initial condition from INTERP RDDATA.46 C 6 MM5 RDDATA.47 C 7 Interpolated model output on pressure levels from INTERP RDDATA.48 C RDDATA.49 IF(HEAD) THEN RDDATA.50 C RDDATA.51 INDEX=MIF(1,1) RDDATA.52 IF(INDEX.EQ.1) THEN RDDATA.53 PRINT *,'READING TERRAIN OUTPUT' RDDATA.54 ELSEIF(INDEX.EQ.2) THEN RDDATA.55 PRINT *,'READING DATAGRID OUTPUT' RDDATA.56 ELSEIF(INDEX.EQ.3) THEN RDDATA.57 PRINT *,'READING RAWINS 3-D ANALYSIS OUTPUT' RDDATA.58 ELSEIF(INDEX.EQ.4) THEN RDDATA.59 PRINT *,'READING RAWINS SURFACE 4DDA OUTPUT' RDDATA.60 ELSEIF(INDEX.EQ.5) THEN RDDATA.61 PRINT *,'READING MODEL INITIAL CONDITION' RDDATA.62 ELSEIF(INDEX.EQ.6) THEN RDDATA.63 PRINT *,'READING MM5 OUTPUT' RDDATA.64 ELSEIF(INDEX.EQ.7) THEN RDDATA.65 PRINT *,'READING INTERPOLATED MODEL OUTPUT ON P' RDDATA.66 END IF RDDATA.67 PRINT *,'DATE = ',MIF(1,INDEX) RDDATA.68 IF (IWR.EQ.1) PRINT *,'** DATA WAS WRITTEN TO UNIT=',IUNWR,' **' RDDATA.69 PRINT *,' ' RDDATA.70 C RDDATA.71 C NUM3D : Number of 3-D fields in this output RDDATA.72 C NUM2D : Number of 2-D fields in this output RDDATA.73 C NUM1D : Number of 1-D fields in this output RDDATA.74 C NUM0D : Number of 0-D fields in this output RDDATA.75 C RDDATA.76 NUM3D = MIF(201,INDEX) RDDATA.77 NUM2D = MIF(202,INDEX) RDDATA.78 NUM1D = MIF(203,INDEX) RDDATA.79 NUM0D = MIF(204,INDEX) RDDATA.80 C RDDATA.81 C ID : Description of the 3-D fields RDDATA.82 C IDOT : Is this field defined on cross or dot points RDDATA.83 C 1 DOT POINT RDDATA.84 C 2 CROSS POINT RDDATA.85 C RDDATA.86 DO 120 I=1,NUM3D RDDATA.87 IDOT=1-MIF(204+I,INDEX)/10 RDDATA.88 ID=MIFC(204+I,INDEX)(1:8) RDDATA.89 IF(ID.EQ.'W ' .AND. MIF( 10,1).EQ.2) THEN RDDATA.90 IF (IEEE.EQ.64) THEN READ(IUNIT) DUM2D_8,DUM3D_8 DO M=1,IX DO N=1,JX DUM2D(M,N) = DUM2D_8(M,N) DO L=1,KX DUM3D(M,N,L) = DUM3D_8(M,N,L) END DO END DO END DO ELSE READ(IUNIT) DUM2D,DUM3D RDDATA.91 ENDIF IF (IWR.EQ.1) WRITE(IUNWR) DUM2D,DUM3D RDDATA.92 ELSE RDDATA.93 IF (IEEE.EQ.64) THEN READ(IUNIT) DUM3D_8 DO M=1,IX DO N=1,JX DO L=1,KX DUM3D(M,N,L) = DUM3D_8(M,N,L) END DO END DO END DO ELSE READ(IUNIT) DUM3D ENDIF IF (IWR.EQ.1) WRITE(IUNWR) DUM3D RDDATA.95 ENDIF RDDATA.96 cc PRINT *,'3D FIELD ID= ',ID,' IDOT= ',IDOT, RDDATA.97 cc * ' SAMPLE VALUE= ',DUM3D(10,10,10) RDDATA.98 IF (ID.EQ.'U ') CALL EQUATE(DUM3D, U,IX,JX,KX,ID) RDDATA.99 IF (ID.EQ.'V ') CALL EQUATE(DUM3D, V,IX,JX,KX,ID) RDDATA.100 IF (ID.EQ.'T ') CALL EQUATE(DUM3D, T,IX,JX,KX,ID) RDDATA.101 IF (ID.EQ.'Q ') CALL EQUATE(DUM3D, Q,IX,JX,KX,ID) RDDATA.102 IF (ID.EQ.'CLW ') CALL EQUATE(DUM3D, QC,IX,JX,KX,ID) RDDATA.103 IF (ID.EQ.'RNW ') CALL EQUATE(DUM3D, QR,IX,JX,KX,ID) RDDATA.104 IF (ID.EQ.'ICE ') CALL EQUATE(DUM3D, QI,IX,JX,KX,ID) RDDATA.105 IF (ID.EQ.'SNOW ') CALL EQUATE(DUM3D, QS,IX,JX,KX,ID) RDDATA.106 IF (ID.EQ.'PP ') CALL EQUATE(DUM3D, PP,IX,JX,KX,ID) RDDATA.107 IF (ID.EQ.'W ' .AND. MIF( 10,1).EQ.2) THEN RDDATA.108 CALL EQUATE(DUM2D,W(1,1,1),IX,JX, 1,ID) RDDATA.109 DO K = 2,KX+1 RDDATA.110 DO II = 1,IX RDDATA.111 DO JJ = 1,JX RDDATA.112 W(II,JJ,K) = DUM3D(II,JJ,K-1) RDDATA.113 END DO RDDATA.114 END DO RDDATA.115 END DO RDDATA.116 C CALL AVERG(DUM3D,IX,JX,KX,ID) MODS.4 END IF RDDATA.118 120 CONTINUE RDDATA.119 PRINT *,' ' RDDATA.120 PRINT *,' ' RDDATA.121 DO 140 I=1,NUM2D RDDATA.122 IDOT=1-MIF(204+NUM3D+I,INDEX)/10 RDDATA.123 ID=MIFC(204+NUM3D+I,INDEX)(1:8) RDDATA.124 IF (IEEE.EQ.64) THEN READ(IUNIT) DUM2D_8 DO M=1,IX DO N=1,JX DUM2D(M,N) = DUM2D_8(M,N) END DO END DO ELSE READ(IUNIT) DUM2D ENDIF IF (IWR.EQ.1) WRITE(IUNWR) DUM2D RDDATA.126 cc PRINT *,'2D FIELD ID= ',ID,' IDOT= ',IDOT, RDDATA.127 cc * ' SAMPLE VALUE= ',DUM2D(10,10) RDDATA.128 IF (ID.EQ.'PSTARCRS') CALL EQUATE(DUM2D, PS,IX,JX, 1,ID) RDDATA.129 IF (ID.EQ.'RAIN CON') CALL EQUATE(DUM2D, RNC,IX,JX, 1,ID) RDDATA.130 IF (ID.EQ.'RAIN NON') CALL EQUATE(DUM2D, RNN,IX,JX, 1,ID) RDDATA.131 IF (ID.EQ.'GROUND T') CALL EQUATE(DUM2D, TG,IX,JX, 1,ID) RDDATA.132 IF (ID.EQ.'RES TEMP') CALL EQUATE(DUM2D, TMN,IX,JX, 1,ID) RDDATA.133 IF (ID.EQ.'CORIOLIS') CALL EQUATE(DUM2D, F,IX,JX, 1,ID) RDDATA.134 IF (ID.EQ.'MAPFACCR') CALL EQUATE(DUM2D, XMF,IX,JX, 1,ID) RDDATA.135 IF (ID.EQ.'MAPFACDT') CALL EQUATE(DUM2D, DMF,IX,JX, 1,ID) RDDATA.136 IF (ID.EQ.'LATITCRS') CALL EQUATE(DUM2D,XLAT,IX,JX, 1,ID) RDDATA.137 IF (ID.EQ.'LONGICRS') CALL EQUATE(DUM2D,XLON,IX,JX, 1,ID) RDDATA.138 IF (ID.EQ.'LATITDOT') CALL EQUATE(DUM2D,DLAT,IX,JX, 1,ID) RDDATA.139 IF (ID.EQ.'LONGIDOT') CALL EQUATE(DUM2D,DLON,IX,JX, 1,ID) RDDATA.140 IF (ID.EQ.'TERRAIN ') CALL EQUATE(DUM2D, TER,IX,JX, 1,ID) RDDATA.141 IF (ID.EQ.'LAND USE') CALL EQUATE(DUM2D,XLND,IX,JX, 1,ID) RDDATA.142 IF (ID.EQ.'SNOWCOVR') CALL EQUATE(DUM2D,SNOW,IX,JX, 1,ID) RDDATA.143 140 CONTINUE RDDATA.144 END IF RDDATA.145 C RDDATA.146 RETURN RDDATA.147 C RDDATA.148 999 CONTINUE RDDATA.149 IEND = 1 RDDATA.150 PRINT *,'EOF ENCOUTERED, IEND=',IEND RDDATA.151 RETURN RDDATA.152 C RDDATA.153 END RDDATA.154 C RDDATA.155 SUBROUTINE WRDATA(IX,JX,KX,U,V,T,Q,W,PP,QC,QR,QI,QS,PS,TG,RNC,RNN, WRDATA.2 1 F, XMF,DMF,XLAT,XLON,DLAT,DLON,TMN,TER,XLND,SNOW, WRDATA.3 2 IUNIT,DUM2D,DUM3D) C WRDATA.5 C IUNIT : unit number for reading WRDATA.6 C IUNWR : unit number for writing WRDATA.7 C HEAD : .TRUE. read all the data, .FALSE. only header record is read WRDATA.8 C IEND : flag to detect the EOF, IEND=1 EOF found. WRDATA.9 C IWR : IWR=1 write out the data, IWR=0 no write out completed. WRDATA.10 C WRDATA.11 C ----------------------------------------------------------------------- WRDATA.12 C WRDATA.13 C MIF : Array store integer variables information WRDATA.14 C MIFC: Character array describs the MIF array WRDATA.15 C MRF : Array store real variables information WRDATA.16 C MRFC: Character array describs the MRF array WRDATA.17 COMMON /HEADER/ MIF, MRF, MIFC, MRFC WRDATA.18 INTEGER MIF(1000,20) WRDATA.19 REAL MRF(1000,20) WRDATA.20 CHARACTER*80 MIFC(1000,20),MRFC(1000,20) WRDATA.21 C WRDATA.22 CHARACTER*8 ID WRDATA.23 DIMENSION DUM3D(IX,JX,KX),DUM2D(IX,JX) WRDATA.24 C WRDATA.25 DIMENSION U(IX,JX,KX), V(IX,JX,KX), W(IX,JX,KX+1), T(IX,JX,KX), WRDATA.26 1 Q(IX,JX,KX),PP(IX,JX,KX),QC(IX,JX,KX), QR(IX,JX,KX), WRDATA.27 1 QI(IX,JX,KX),QS(IX,JX,KX), WRDATA.28 2 PS(IX,JX), TG(IX,JX), RNC(IX,JX), RNN(IX,JX), WRDATA.29 3 F(IX,JX), XMF(IX,JX), DMF(IX,JX),XLAT(IX,JX), WRDATA.30 4 XLON(IX,JX),DLAT(IX,JX),DLON(IX,JX), TMN(IX,JX), WRDATA.31 5 TER(IX,JX),XLND(IX,JX),SNOW(IX,JX) WRDATA.32 C WRDATA.33 PRINT *,'MM5 version 1' WRDATA.34 PRINT *,' ' WRDATA.35 C WRDATA.36 C INDEX : output is generated by which program? WRDATA.37 C 1 TERRAIN WRDATA.38 C 2 DATAGRID WRDATA.39 C 3 RAWINS 3-D analysis WRDATA.40 C 4 RAWINS surface 4DDA WRDATA.41 C 5 MM5 initial condition from INTERP WRDATA.42 C 6 MM5 WRDATA.43 C 7 Interpolated model output on pressure levels from INTERP WRDATA.44 C WRDATA.45 INDEX=MIF(1,1) WRDATA.46 PRINT *,'DATE = ',MIF(1,INDEX) WRDATA.47 PRINT *,' ' WRDATA.48 IF(INDEX.EQ.1) THEN WRDATA.49 PRINT *,'WRITING TERRAIN OUTPUT' WRDATA.50 ELSEIF(INDEX.EQ.2) THEN WRDATA.51 PRINT *,'WRITING DATAGRID OUTPUT' WRDATA.52 ELSEIF(INDEX.EQ.3) THEN WRDATA.53 PRINT *,'WRITING RAWINS 3-D ANALYSIS OUTPUT' WRDATA.54 ELSEIF(INDEX.EQ.4) THEN WRDATA.55 PRINT *,'WRITING RAWINS SURFACE 4DDA OUTPUT' WRDATA.56 ELSEIF(INDEX.EQ.5) THEN WRDATA.57 PRINT *,'WRITING MODEL INITIAL CONDITION' WRDATA.58 ELSEIF(INDEX.EQ.6) THEN WRDATA.59 PRINT *,'WRITING MM5 OUTPUT' WRDATA.60 ELSEIF(INDEX.EQ.7) THEN WRDATA.61 PRINT *,'WRITING INTERPOLATED MODEL OUTPUT ON P' WRDATA.62 END IF WRDATA.63 C WRDATA.64 WRITE(IUNIT) MIF,MRF,MIFC,MRFC WRDATA.65 C WRDATA.66 C NUM3D : Number of 3-D fields in this output WRDATA.67 C NUM2D : Number of 2-D fields in this output WRDATA.68 C NUM1D : Number of 1-D fields in this output WRDATA.69 C NUM0D : Number of 0-D fields in this output WRDATA.70 C WRDATA.71 NUM3D = MIF(201,INDEX) WRDATA.72 NUM2D = MIF(202,INDEX) WRDATA.73 NUM1D = MIF(203,INDEX) WRDATA.74 NUM0D = MIF(204,INDEX) WRDATA.75 C WRDATA.76 C ID : Description of the 3-D fields WRDATA.77 C IDOT : Is this field defined on cross or dot points WRDATA.78 C 1 DOT POINT WRDATA.79 C 2 CROSS POINT WRDATA.80 C WRDATA.81 DO 120 I=1,NUM3D WRDATA.82 IDOT=1-MIF(204+I,INDEX)/10 WRDATA.83 ID=MIFC(204+I,INDEX)(1:8) WRDATA.84 IF (ID.EQ.'U ') CALL EQUATE( U,DUM3D,IX,JX,KX,ID) WRDATA.85 IF (ID.EQ.'V ') CALL EQUATE( V,DUM3D,IX,JX,KX,ID) WRDATA.86 IF (ID.EQ.'T ') CALL EQUATE( T,DUM3D,IX,JX,KX,ID) WRDATA.87 IF (ID.EQ.'Q ') CALL EQUATE( Q,DUM3D,IX,JX,KX,ID) WRDATA.88 IF (ID.EQ.'CLW ') CALL EQUATE( QC,DUM3D,IX,JX,KX,ID) WRDATA.89 IF (ID.EQ.'RNW ') CALL EQUATE( QR,DUM3D,IX,JX,KX,ID) WRDATA.90 IF (ID.EQ.'ICE ') CALL EQUATE( QI,DUM3D,IX,JX,KX,ID) WRDATA.91 IF (ID.EQ.'SNOW ') CALL EQUATE( QS,DUM3D,IX,JX,KX,ID) WRDATA.92 IF (ID.EQ.'PP ') CALL EQUATE( PP,DUM3D,IX,JX,KX,ID) WRDATA.93 IF (ID.EQ.'W ' .AND. MIF( 10,1).EQ.2) THEN WRDATA.94 CALL EQUATE(W(1,1,1),DUM2D,IX,JX, 1,ID) WRDATA.95 DO K = 2,KX+1 WRDATA.96 DO II = 1,IX WRDATA.97 DO JJ = 1,JX WRDATA.98 DUM3D(II,JJ,K-1) = W(II,JJ,K) WRDATA.99 END DO WRDATA.100 END DO WRDATA.101 END DO WRDATA.102 CALL AVERG(DUM3D,IX,JX,KX,ID) WRDATA.103 END IF WRDATA.104 IF(ID.EQ.'W ' .AND. MIF( 10,1).EQ.2) THEN WRDATA.105 WRITE(IUNIT) DUM2D,DUM3D WRDATA.106 ELSE WRDATA.107 WRITE(IUNIT) DUM3D WRDATA.108 ENDIF WRDATA.109 PRINT *,'3D FIELD ID= ',ID,' IDOT= ',IDOT, WRDATA.110 * ' SAMPLE VALUE= ',DUM3D(10,10,10) WRDATA.111 120 CONTINUE WRDATA.112 PRINT *,' ' WRDATA.113 PRINT *,' ' WRDATA.114 DO 140 I=1,NUM2D WRDATA.115 IDOT=1-MIF(204+NUM3D+I,INDEX)/10 WRDATA.116 ID=MIFC(204+NUM3D+I,INDEX)(1:8) WRDATA.117 IF (ID.EQ.'PSTARCRS') CALL EQUATE( PS,DUM2D,IX,JX, 1,ID) WRDATA.118 IF (ID.EQ.'RAIN CON') CALL EQUATE( RNC,DUM2D,IX,JX, 1,ID) WRDATA.119 IF (ID.EQ.'RAIN NON') CALL EQUATE( RNN,DUM2D,IX,JX, 1,ID) WRDATA.120 IF (ID.EQ.'GROUND T') CALL EQUATE( TG,DUM2D,IX,JX, 1,ID) WRDATA.121 IF (ID.EQ.'RES TEMP') CALL EQUATE( TMN,DUM2D,IX,JX, 1,ID) WRDATA.122 IF (ID.EQ.'CORIOLIS') CALL EQUATE( F,DUM2D,IX,JX, 1,ID) WRDATA.123 IF (ID.EQ.'MAPFACCR') CALL EQUATE( XMF,DUM2D,IX,JX, 1,ID) WRDATA.124 IF (ID.EQ.'MAPFACDT') CALL EQUATE( DMF,DUM2D,IX,JX, 1,ID) WRDATA.125 IF (ID.EQ.'LATITCRS') CALL EQUATE(XLAT,DUM2D,IX,JX, 1,ID) WRDATA.126 IF (ID.EQ.'LONGICRS') CALL EQUATE(XLON,DUM2D,IX,JX, 1,ID) WRDATA.127 IF (ID.EQ.'LATITDOT') CALL EQUATE(DLAT,DUM2D,IX,JX, 1,ID) WRDATA.128 IF (ID.EQ.'LONGIDOT') CALL EQUATE(DLON,DUM2D,IX,JX, 1,ID) WRDATA.129 IF (ID.EQ.'TERRAIN ') CALL EQUATE( TER,DUM2D,IX,JX, 1,ID) WRDATA.130 IF (ID.EQ.'LAND USE') CALL EQUATE(XLND,DUM2D,IX,JX, 1,ID) WRDATA.131 IF (ID.EQ.'SNOWCOVR') CALL EQUATE(SNOW,DUM2D,IX,JX, 1,ID) WRDATA.132 WRITE(IUNIT) DUM2D WRDATA.133 PRINT *,'2D FIELD ID= ',ID,' IDOT= ',IDOT, WRDATA.134 * ' SAMPLE VALUE= ',DUM2D(10,10) WRDATA.135 140 CONTINUE WRDATA.136 C WRDATA.137 RETURN WRDATA.138 C WRDATA.139 END WRDATA.140 C WRDATA.141 SUBROUTINE GETGIST(MIF,MRF,MIFC,MRFC) GETGIST.2 C GETGIST.3 C PURPOSE INTERPRET THE VERSION 1 HEADER INFO GETGIST.4 C GETGIST.5 INTEGER MIF(1000,20) GETGIST.6 REAL MRF(1000,20) GETGIST.7 CHARACTER*80 MIFC(1000,20),MRFC(1000,20) GETGIST.8 GETGIST.9 DO 30 J=1,20 GETGIST.10 DO 10 I=1,1000 GETGIST.11 IF(MIF(I,J).NE.-999) PRINT 100,I,J,MIF(I,J),MIFC(I,J) GETGIST.12 10 CONTINUE GETGIST.13 DO 20 I=1,1000 GETGIST.14 IF(MRF(I,J).NE.-999.) PRINT 110,I,J,MRF(I,J),MRFC(I,J) GETGIST.15 20 CONTINUE GETGIST.16 30 CONTINUE GETGIST.17 GETGIST.18 100 FORMAT('MIF(',I3,',',I1,') = ',I10,' : ',A80) GETGIST.19 110 FORMAT('MRF(',I3,',',I1,') = ',F10.3,' : ',A80) GETGIST.20 RETURN GETGIST.21 END GETGIST.22 SUBROUTINE EQUATE(A,B,I1,J1,K1,VAR) EQUATE.2 C EQUATE.3 C ******** put A to B ********* EQUATE.4 C EQUATE.5 DIMENSION A(I1,J1,K1), B(I1,J1,K1) EQUATE.6 CHARACTER VAR*8 EQUATE.7 C EQUATE.8 DO K = 1,K1 EQUATE.9 DO I = 1,I1 EQUATE.10 DO J = 1,J1 EQUATE.11 B(I,J,K) = A(I,J,K) EQUATE.12 END DO EQUATE.13 END DO EQUATE.14 END DO EQUATE.15 C CALL AVERG(A,I1,J1,K1,VAR) MODS.2 C EQUATE.17 RETURN EQUATE.18 END EQUATE.19 C EQUATE.20 SUBROUTINE AVERG(F,IX,JX,KX,VAR) AVERG.2 C AVERG.3 DIMENSION F(IX,JX,KX),SUM(100) AVERG.4 CHARACTER*8 VAR AVERG.5 C AVERG.6 SIJ=FLOAT(IX-1)*FLOAT(JX-1) AVERG.7 DO 20 K=1,KX AVERG.8 SUM(K) = 0.0 AVERG.9 DO 10 I = 1,IX-1 AVERG.10 DO 10 J = 1,JX-1 AVERG.11 SUM(K) = SUM(K) + F(I,J,K) AVERG.12 10 CONTINUE AVERG.13 SUM(K) = SUM(K)/SIJ AVERG.14 20 CONTINUE AVERG.15 C AVERG.16 PRINT 25,VAR AVERG.17 25 FORMAT(2X,'VAR =',A8) AVERG.18 PRINT 30, (K,SUM(K),K=1,KX) AVERG.19 30 FORMAT(7(2X,I3,1X,E12.4)) AVERG.20 C AVERG.21 RETURN AVERG.22 END AVERG.23