C**** AIJL070.FOR datafile from Atmospheric IxJxL data 2001/10/31 C**** C**** AIJL070 reads several Climate Model III D diles, calculates C**** specified quantities from the AIJL accumulating arrays, and C**** writes the scaled data to a disk file. Each record of the C**** output file contains an 80 byte title and a REAL*4 IMxJM array. C**** INCLUDE '/u/cmrun/C070.COM' PARAMETER (KDINT = 15 + 1 + 4 + 2*4 + 42*50, * KDACC = JM*KAJ*6 + JM*LMA*KAJL + JM*3*4 + IM*JM*KAIJ + * IM*JM*LMA*KAIJL + IM*JM*LMO*KOIJL + LMO*NMST*KOLNST + * 24*50*4 + JM*KCON) INTEGER*4 IPARM(300),IDIAG(KDINT) REAL*4 DIAGR4(KDACC) EQUIVALENCE (IPARM,IM$) C**** CHARACTER FILEIN*80, TITLE*80, NAME*50, OUTYR*4,OUTMON*4 INTEGER*4 LMINM,LMAXM,KVMF(8), LMINE,LMAXE,KVEF(8), * LMINQ,LMAXQ,KVQF(8) LOGICAL*4 QMFEW,QMFNS,QMFC, QEFEW,QEFNS,QEFC, * QQFEW,QQFNS,QQFC, QK(12) REAL*8 X8(IM,JM) COMMON X(IM,JM) COMMON /NAMECB/ NAME(12) EQUIVALENCE (QMFEW,QK( 2)),(QMFNS,QK( 3)),(QMFC,QK(1)), * (QEFEW,QK( 6)),(QEFNS,QK( 7)),(QEFC,QK(5)), * (QQFEW,QK(10)),(QQFNS,QK(11)),(QQFC,QK(9)) C**** NAMELIST /INPUTZ/ * QMFEW,QMFNS,QMFC, QEFEW,QEFNS,QEFC, QQFEW,QQFNS,QQFC, * LMINM,LMAXM,KVMF, LMINE,LMAXE,KVEF, LMINQ,LMAXQ,KVQF C**** NARGS = IARGC() IF(NARGS.le.0) GO TO 800 OPEN (6,FILE='AIJL070.PRT') C**** C**** Read first input file to determine KAIJL0 and KDACCX C**** CALL GETARG (1,FILEIN) OPEN (1,FILE=FILEIN,FORM='UNFORMATTED',STATUS='OLD',ERR=810) READ (1) IHOUR,LABEL,IPARM CLOSE (1) KAIJL0 = JM*KAJ$*6 + JM*LMA$*KAJL$ + JM*3*4 + IM*JM*KAIJ$ KDACCX = KAIJL0 + IM*JM*LMA$*KAIJL$ + IM*JM*LMO$*KOIJL$ + * LMO$*NMST$*KOLNS$ + 24*50*4 + JM*KCON$ WRITE (6,*) 'KDINT,KDACCX =',KDINT,KDACCX C**** C**** Determine output quantities from Namelist input file: AIJL070.I C**** FILEIN = 'AIJL070.I' OPEN (5,FILE=FILEIN,STATUS='OLD',ERR=810) READ (5,INPUTZ) CLOSE (5) CALL SGEOM C**** C**** Zero out summing arrays C**** DO 10 N=1,15 10 IDACC(N) = 0 DO 20 I=1,IM*JM*LMA*12 20 AIJL(I,1,1,1) = 0. C**** C**** Loop over the input disk files C**** KFILE = 0 100 KFILE = KFILE + 1 IF(KFILE.gt.NARGS) GO TO 200 CALL GETARG (KFILE,FILEIN) C**** Open and read input D file OPEN (1,FILE=FILEIN,FORM='UNFORMATTED',STATUS='OLD',ERR=810) READ (1) IHOURX,LABEL,IPARM,IDIAG,(DIAGR4(K),K=1,KDACCX),IHOURY CLOSE (1) IF(IHOURX.ne.IHOURY) GO TO 820 CALL STORYM (JYEAR0,JMON0, JYEAR,JMON) WRITE (6,910) JYEAR0,JMON0, JYEAR,JMON, FILEIN(1:60) C**** Accumulate diagnostics for time averaging DO 110 N=1,15 110 IDACC(N) = IDACC(N) + IDIAG(N) DO 120 I=1,IM*JM*LMA*12 120 AIJL(I,1,1,1) = AIJL(I,1,1,1) + DIAGR4(KAIJL0+I) GO TO 100 C**** C**** End of input files: print table of input years and months C**** 200 CALL PRNTYM (OUTYR,OUTMON) OPEN (2,FILE='AIJL070.O',FORM='UNFORMATTED') C**** C**** Easterly or northerly air mass flux (10^6 kg/s) C**** DO 304 K=2,3 IF(.not.QK(K)) GO TO 304 DO 301 I=1,IM*JM 301 X(I,1) = 0. DO 303 I=1,IM*(JM-1) DO 302 L=LMINM,LMAXM 302 X(I,1) = X(I,1) + AIJL(I,1,L,K) 303 X(I,1) = X(I,1)*2.d-6 / (IDACC(1)*NDYNA) IF(LMINM.eq.LMAXM) WRITE (NAME(K)(43:44),930) LMINM IF(LMINM.lt.LMAXM) WRITE (NAME(K)(43:46),931) LMINM,LMAXM CALL WRITED (NAME(K),LABEL,OUTYR,OUTMON) 304 continue C**** C**** Upward vertical mass flux (10^-3 kg/s*m^2) C**** DO 323 K=1,8 IF(KVMF(K).le.0) GO TO 400 L =KVMF(K) DO 321 J=1,JM DO 321 I=1,IM 321 X(I,J) = AIJL(I,J,L,4)*2.d3 / (DXYP(J)*IDACC(1)*NDYNA) DO 322 I=2,IM X(I-1,1) = X(IM,1) 322 X(I,JM) = X(1,JM) WRITE (NAME(4)(47:48),930) L 323 CALL WRITED (NAME(4),LABEL,OUTYR,OUTMON) C**** C**** Easterly or northerly potential enthalpy flux (10^12 W) C**** 400 DO 404 K=6,7 IF(.not.QK(K)) GO TO 404 DO 401 I=1,IM*JM 401 X(I,1) = 0. DO 403 I=1,IM*(JM-1) DO 402 L=LMINE,LMAXE 402 X(I,1) = X(I,1) + AIJL(I,1,L,K) 403 X(I,1) = X(I,1)*1.d-12 / (IDACC(1)*DTS) IF(LMINE.eq.LMAXE) WRITE (NAME(K)(46:47),930) LMINE IF(LMINE.lt.LMAXE) WRITE (NAME(K)(46:49),931) LMINQ,LMAXE CALL WRITED (NAME(K),LABEL,OUTYR,OUTMON) 404 continue C**** C**** Converged potential enthalpy flux (10^12 W) C**** IF(.not.QK(5)) GO TO 500 DO 441 I=1,IM*JM 441 X8(I,1) = 0. C**** Interior cells Im1=IM DO 443 I=1,IM DO 442 L=LMINE,LMAXE DO 442 J=2,JM-1 442 X8(I,J) = X8(I,J) + AIJL(Im1,J,L,6) - AIJL(I,J,L,6) + + AIJL(I,J-1,L,7) - AIJL(I,J,L,7) 443 Im1=I C**** Poles DO 444 L=LMINE,LMAXE DO 444 I=1,IM X8(IM,1) = X8(IM,1) - AIJL(I,1 ,L,7) 444 X8(IM,JM) = X8(IM,JM) + AIJL(I,JM,L,7) DO 445 I=1,IM X8(I,1) = X8(IM,1) / IM 445 X8(I,JM) = X8(IM,JM) / IM C**** DO 446 I=1,IM*JM 446 X(I,1) = X8(I,1)*1.d-12 / (IDACC(1)*DTS) IF(LMINE.eq.LMAXE) WRITE (NAME(5)(46:47),930) LMINE IF(LMINE.lt.LMAXE) WRITE (NAME(5)(46:49),931) LMINQ,LMAXE CALL WRITED (NAME(5),LABEL,OUTYR,OUTMON) C**** C**** Easterly or northerly water vapor flux (10^3 kg/s) C**** 500 DO 504 K=10,11 IF(.not.QK(K)) GO TO 504 DO 501 I=1,IM*JM 501 X(I,1) = 0. DO 503 I=1,IM*(JM-1) DO 502 L=LMINQ,LMAXQ 502 X(I,1) = X(I,1) + AIJL(I,1,L,K) 503 X(I,1) = X(I,1)*1.d-6 / (IDACC(1)*DTS) IF(LMINQ.eq.LMAXQ) WRITE (NAME(K)(46:47),930) LMINQ IF(LMINQ.lt.LMAXQ) WRITE (NAME(K)(46:49),931) LMINQ,LMAXQ CALL WRITED (NAME(K),LABEL,OUTYR,OUTMON) 504 continue C**** CLOSE (2) CLOSE (6) GO TO 999 C**** 800 WRITE (0,*) 'Usage: AIJL070 /raid1/C070/DJan1* ', * 'Make Atmosphere IxJ datafiles' WRITE (0,*) 'Check or edit the file: AIJL070.I 2001/10/31' GO TO 999 810 WRITE (0,*) 'Error accessing ',FILEIN STOP 810 820 WRITE (0,*) 'IHOURX and IHOURY do not match:',IHOURX,IHOURY STOP 820 C**** 910 FORMAT (' From',I6,A6,'to',I6,A6,' FILEIN= ',A) 930 FORMAT (I2) 931 FORMAT (I2,'-',I1) 999 END SUBROUTINE SGEOM IMPLICIT REAL*8 (A-H,M,O-Z) PARAMETER (IM=72,JM=46, * TWOPI=6.283185307179586477d0, RADIUS=6375000.) COMMON /GEOMCB/ DXYP(JM),DXP(JM),DYP(JM),DXV(JM) C**** C**** Calculates the spherical geometry for the C grid C**** DLON = TWOPI/IM DLAT = TWOPI*NINT(360./(JM-1))/720. FJEQ = .5*(1+JM) C**** Geometric parameters centered at secondary latitudes PLATS = -TWOPI/4. PSINS = SIN(PLATS) DO 10 J=1,JM-1 PLATN = DLAT*(J+1.-FJEQ) IF(J.eq.JM-1) PLATN = TWOPI/4. PSINN = SIN(PLATN) DXV(J) = DLON*RADIUS*(PSINN-PSINS) / (PLATN-PLATS) PLATS = PLATN 10 PSINS = PSINN C**** Geometric parameters centered at primary latitudes VLATS = -TWOPI/4. VSINS = SIN(VLATS) DO 20 J=1,JM VLATN = DLAT*(J+.5-FJEQ) IF(J.eq.JM) VLATN = TWOPI/4. VSINN = SIN(VLATN) DXYP(J)= DLON*RADIUS*RADIUS*(VSINN-VSINS) DXP(J) =.5*(DXV(J-1)+DXV(J)) DYP(J) = (VLATN-VLATS)*RADIUS VLATS = VLATN 20 VSINS = VSINN DXP(1) = .5*DXV(1) DXP(JM)= .5*DXV(JM-1) RETURN END SUBROUTINE STORYM (JYEAR0,JMON0, JYEAR,JMON) C**** C**** STORYM receives years and months and stores them in an array. C**** C**** Start of accumulation period: JYEAR0, JMON0, day 1, hour 0 C**** End of accumulation period: JYEAR, JMON, day 1, hour 0 C**** INTEGER*4 NYofM(12) CHARACTER*1 QMY(12,0:2500) CHARACTER*4 JMON0,JMON, MON(12), OUTYR,OUTMON DATA QMY /30012*' '/, NYofM/12*0/, MINYR/2501/, MAXYR/-1/ DATA MON /'Jan','Feb','Mar','Apr','May','Jun', * 'Jul','Aug','Sep','Oct','Nov','Dec'/ C**** IF(JMON0.eq.'Ann ') JMON0 = 'Jan ' ! compatible with prior vers IF(JYEAR0.gt.2500) JYEAR0 = 1900 + JYEAR0/100 DO 10 I=1,12 10 IF(JMON0.eq.MON(I)) GO TO 20 WRITE (6,901) JYEAR0,JMON0, JYEAR,JMON, 'JMON0 is not a month.' WRITE (0,901) JYEAR0,JMON0, JYEAR,JMON, 'JMON0 is not a month.' STOP 10 20 IMON0 = I DO 30 I=1,12 30 IF(JMON.eq.MON(I)) GO TO 40 WRITE (6,901) JYEAR0,JMON0, JYEAR,JMON, 'JMON is not a month.' WRITE (0,901) JYEAR0,JMON0, JYEAR,JMON, 'JMON is not a month.' STOP 30 40 IMON = I IF(IMON.gt.IMON0) then IMON = IMON-1 IYEAR = JYEAR else IMON = IMON+11 IYEAR = JYEAR-1 endif C**** DO 50 IY=JYEAR0,IYEAR DO 50 IM=IMON0 ,IMON IF(QMY(IM,IY).eq.'*') GO TO 805 QMY(IM,IY) = '*' JM = 1 + MOD(IM-1,12) NYofM(JM) = NYofM(JM) + 1 IF(JYEAR0.lt.MINYR) MINYR = JYEAR0 50 IF(JYEAR .gt.MAXYR) MAXYR = JYEAR RETURN C**** C**** C**** ENTRY PRNTYM (OUTYR,OUTMON) C**** C**** PRNTYM prints a table of input years and month, and C**** calculates OUTYR and OUTMON C**** C**** Output: OUTYR = character describing input years C**** OUTMON = character describing input months C**** C**** Produce printer table of months and years received C**** WRITE (6,910) DO 110 IY=MINYR,MAXYR 110 WRITE (6,911) IY,(QMY(IM,IY),IM=1,12) C**** C**** Determine output month: a single month, three months, or an annual C**** DO 210 M=1,12 210 IF(NYofM(M).gt.0) GO TO 220 GO TO 800 C**** Is output month a single month ? 220 M1 = M DO 230 M=M1+1,12 230 IF(NYofM(M).gt.0) GO TO 240 OUTMON = MON(M1) GO TO 400 C**** Is output twelve months ? 240 IF(M1.ne.1) GO TO 260 DO 250 M=2,12 250 IF(NYofM(M).ne.NYofM(M1)) GO TO 260 OUTMON = 'Ann ' GO TO 400 C**** Is output month three consecutive months ? 260 IF(M1.ge.11) GO TO 800 IF(NYofM(M1+1).ne.NYofM(M1)) GO TO 280 IF(NYofM(M1+2).ne.NYofM(M1)) GO TO 300 DO 270 M=M1+3,12 270 IF(NYofM(M).ne.0) GO TO 800 OUTMON = MON(M1)(1:1) // MON(M1+1)(1:1) // MON(M1+2)(1:1) // ' ' GO TO 400 C**** Is output 3 months November, December and January ? 280 IF(NYofM(11).ne.NYofM(1) .or. NYofM(12).ne.NYofM(1)) GO TO 800 DO 290 M=2,10 290 IF(NYofM(M).ne.0) GO TO 800 OUTMON = 'NDJ ' GO TO 400 C**** Is output 3 months December, January and February ? 300 IF(NYofM(12).ne.NYofM(1) .or. NYofM(2).ne.NYofM(1)) GO TO 800 DO 310 M=3,11 310 IF(NYofM(M).ne.0) GO TO 800 OUTMON = 'DJF ' C**** C**** Calculate the first and last years received, C**** and determine a character string describing those years C**** 400 MAXYR = MINYR + NYofM(M1) - 1 WRITE (OUTYR,940) MINYR IF(MINYR.lt.MAXYR) * WRITE (OUTYR,941) MOD(MINYR,100),MOD(MAXYR,100) IF(MINYR+8.le.MAXYR .and. MINYR/10.eq.MAXYR/10) * WRITE (OUTYR,942) MINYR/10 WRITE (6,943) OUTYR,OUTMON RETURN C**** 800 WRITE (6,*) 'From AIJL070: inconsistant year and months received' WRITE (0,*) 'From AIJL070: inconsistant year and months received' STOP 800 805 WRITE (6,901) JYEAR0,JMON0, JYEAR,JMON, 'accumulated already' WRITE (0,901) JYEAR0,JMON0, JYEAR,JMON, 'accumulated already' STOP 805 C**** 901 FORMAT (' From',I6,A5,' to',I6,A5,1X,A) 910 FORMAT ('0The following months and years were received:' / '0', * 9X,'Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec') 911 FORMAT (1X,I6,21A5) 940 FORMAT (I4) 941 FORMAT (2I2.2) 942 FORMAT (I3,'X') 943 FORMAT ('0Description of the years and months above:',2A5) END SUBROUTINE WRITED (NAME,LABEL,OUTYR,OUTMON) C**** C**** Write record to data file whose format is: TITLE(80),X(IM,JM,LMA) C**** Input: NAME = name of quantity C**** LABEL = run number C**** OUTYR = character year C**** OUTMON = character month C**** X = REAL*8 array to be written to disk C**** PARAMETER (IM=72,JM=46) CHARACTER NAME*50,LABEL*5,OUTYR*4,OUTMON*4, TITLE*80 REAL*8 X COMMON X(IM,JM) C**** Build TITLE WRITE (TITLE,901) NAME,LABEL,OUTYR,OUTMON C**** Write record to disk WRITE (2) TITLE,(SNGL(X(I,1)),I=1,IM*JM) WRITE (6,902) TITLE,(X(IM/2+1,J),J=1,JM) RETURN C**** 901 FORMAT (A50,A9,A9,1X,A3) 902 FORMAT ('0',A72 / (12F11.3)) END BLOCK DATA C**** C**** Names of quantities C**** CHARACTER*50 NAME COMMON /NAMECB/ NAME(12) DATA NAME / 1'CONVERGED AIR MASS FLUX (10^6 kg/s), Layer 1', 2'EASTERLY AIR MASS FLUX (10^6 kg/s), Layer 1', 3'NORTHERLY AIR MASS FLUX (10^6 kg/s), Layer 1', 4'UPWARD VERTICAL MASS FLUX (10^-3 kg/s*m^2), Lr 1', 5'CONVERGED POT. ENTHALPY FLUX (10^12 W), Layer 1', 6'EASTERLY POT. ENTHALPY FLUX (10^12 W), Layer 1', 7'NORTHERLY POT. ENTHALPY FLUX (10^12 W), Layer 1', 8' ', 9'CONVERGED WATER VAPOR FLUX (10^3 kg/s), Layer 1', 1O'EASTERLY WATER VAPOR FLUX (10^3 kg/s), Layer 1', 11'NORTHERLY WATER VAPOR FLUX (10^3 kg/s), Layer 1', 12' '/ END