C**** AIJ070.S make Atmospheric IxJ data file 1999/09/20 C**** C**** AIJ070 reads several Climate Model III D files, calculates C**** specified quantities from the AIJ and AIJL accumulating arrays, C**** and 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$),(IDIAG,IDACC) C**** PARAMETER (KHMAX=7, PPVSF=610.571d0, TKF=273.16d0) LOGICAL*4 QOUT(KAIJ), QMA,QMWV,QPSL,QPCT,QTCT,QMSI,QGISA,QISC, * QRHS,QALBP,QALBS,QNHS,QTSADV,QTGDV,QPRESD,QTSASD,QPSSD, * QCSIM,QCSIV, * QH(KHMAX), QH1000,QH850,QH700,QH500,QH300,QH100,QH30 INTEGER*4 IDACCS(15), IA(KAIJ) CHARACTER FILEIN*80, TITLE*80, NAME*50,NAMEX*50, * CH(KHMAX)*4, OUTYR*4,OUTMON*4 REAL*8 SCALE(KAIJ), RH(KHMAX),DH(KHMAX) COMMON X(IM,JM), QH1000,QH850,QH700,QH500,QH300,QH100,QH30 COMMON /NAMECB/ NAME(KAIJ),NAMEX(20) EQUIVALENCE (QH,QH1000) C**** NAMELIST /INPUTZ/ QOUT, QMA,QMWV,QPSL,QPCT,QTCT,QMSI,QGISA,QISC, * QRHS,QALBP,QALBS,QNHS,QTSADV,QTGDV,QPRESD,QTSASD,QPSSD, * QCSIM,QCSIV, QH1000,QH850,QH700,QH500,QH300,QH100,QH30 DATA IA /1,1,1,1,1, 1,1,1,1,12, 12,12,12,1,1, 1,4,2,2,1, * 2,1,1,2,2, 2,2,3,1,1, 1,1,1,1,1, 3,3,1,2,2, * 2,2,2,1,1, 1,3,3,3,3, 3,1,1,1,1, 1,1,1,1,1, * 1,1,1,1,1, 1,1,1,1,1, 1,1,12,12,12, 3/ DATA SCALE /KAIJ*1./ DATA DH / 0., 1500., 3000., 5600., 9500.,16400.,24000./, * RH / 1000., 850., 700., 500., 300., 100., 30./, * CH /'1000',' 850',' 700',' 500',' 300',' 100',' 30'/ C**** PPVSAT(TK,EL) = PPVSF*EXP(EL*(1./TKF-1./TK)/RVAP) NARGS = IARGC() IF(IARGC().le.0) GO TO 800 OPEN (6,FILE='AIJ070.PRT') C**** Read first input file to determine KAIJ0, KAIJL0, KDACCx CALL GETARG (1,FILEIN) OPEN (1,FILE=FILEIN,FORM='UNFORMATTED',STATUS='OLD',ERR=810) READ (1) IHOURX,LABEL,IPARM CLOSE (1) KAIJ0 = JM*KAJ$*6 + JM*LMA$*KAJL$ + JM*3*4 KAIJL0 = KAIJ0 + 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 C**** FILEIN = 'AIJ070.I ' OPEN (5,FILE=FILEIN,STATUS='OLD',ERR=810) READ (5,INPUTZ) CLOSE (5) CALL SGEOM C**** C**** Read in fixed arrays C**** FILEIN = '/u/cmrun/Z72X46N' OPEN (11,FILE=FILEIN,FORM='UNFORMATTED',STATUS='OLD',ERR=810) CALL READR4 (11,IM*JM,FOCEAN,FOCEAN) READ (11) CALL READR4 (11,IM*JM,FGRND,FGRND) CALL READR4 (11,IM*JM,FGICE,FGICE) CALL READR4 (11,IM*JM,ZATMO,ZATMO) CLOSE (11) C**** C**** Zero out summing arrays C**** DO 10 N=1,15 10 IDACCS(N) = 0 DO 20 I=1,IM*JM*KAIJ 20 AIJ(I,1,1) = 0. DO 30 I=1,IM*JM*LMA*2 30 AIJL(I,1,1,1) = 0. C**** C**** Define scaling paramsters for some of the quantities C**** 50 SCALE( 1) = 100. SCALE( 2) = 100. SCALE( 4) = -1./DTS SCALE( 5) = NDAY SCALE( 6) = NDAY SCALE( 7) = 1.d2/NSURF SCALE( 8) = NDAY*365. SCALE( 9) = 1./DTS SCALE(14) = 1.d-2 SCALE(15) = NDAY SCALE(17) = 1.d2 SCALE(19) = 100. SCALE(20) = 1.d-10/DTS SCALE(21) = -1. SCALE(22) = -1./DTS SCALE(23) = 1./DTS SCALE(29) = 1.d2/GRAV SCALE(30) = 1.d-6/DTS SCALE(31) = 1.d-6/DTS SCALE(32) = NDAY SCALE(33) = NDAY SCALE(34) = 1.d-5/DTS SCALE(35) = 1./NSURF SCALE(38) = 1.d-2 SCALE(41) = 100. SCALE(42) = 100. SCALE(43) = 100. SCALE(44) = NDAY SCALE(45) = NDAY SCALE(46) = NDAY SCALE(47) = 360./TWOPI SCALE(48) = NSURF/DTS SCALE(49) = NSURF/DTS SCALE(50) = 1.d3 SCALE(52) = 1./DTS SCALE(53) = NDAY SCALE(54) = NDAY SCALE(55) = NDAY SCALE(56) = NDAY SCALE(57) = 1./DTS SCALE(58) = 1./DTS SCALE(59) = 1./DTS SCALE(60) = 1./DTS SCALE(61) = NDAY SCALE(62) = 1./DTS SCALE(63) = NDAY SCALE(64) = 1./DTS SCALE(65) = NDAY SCALE(66) = 1./DTS SCALE(69) = .5/DTS SCALE(70) = .5/DTS SCALE(71) = 100./4. SCALE(72) = 100./4. SCALE(74) = 1./(NDAY*NDAY*NSURF*NSURF) SCALE(75) = 1.d-4/(NDAY*NDAY) SCALE(76) = NSURF/DTS C**** C**** Loop over the input disk files C**** KFILE=0 100 KFILE=KFILE+1 IF(KFILE.gt.NARGS) GO TO 190 CALL GETARG (KFILE,FILEIN) C**** Open and read input 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,911) JYEAR0,JMON0, JYEAR,JMON, FILEIN(1:60) C**** Accumulate diagnostics for time averaging DO 130 N=1,15 130 IDACCS(N) = IDACCS(N) + IDACC(N) DO 140 I=1,IM*JM*KAIJ 140 AIJ(I,1,1) = AIJ(I,1,1) + DIAGR4(KAIJ0+I) DO 150 I=1,IM*JM*LMA AIJL(I,1,1,1) = AIJL(I,1,1,1) + DIAGR4(KAIJL0+I) AIJL(I,1,1,5) = AIJL(I,1,1,5) + DIAGR4(KAIJL0+IM*JM*LMA*4+I) 150 AIJL(I,1,1,9) = AIJL(I,1,1,9) + DIAGR4(KAIJL0+IM*JM*LMA*8+I) GO TO 100 190 AIJ(1,1,14) = AIJ(IM,1,14) C**** C**** End of input files: print table of input months and years C**** CALL PRNTYM (OUTYR,OUTMON) OPEN (2,FILE='AIJ070.O',FORM='UNFORMATTED') C**** C**** Quantites that are scaled but not calculated C**** DO 202 K=1,KAIJ IF(.not.QOUT(K)) GO TO 202 DO 201 I=1,IM*JM 201 X(I,1) = AIJ(I,1,K)*SCALE(K)/IDACCS(IA(K)) CALL WRITED (NAME(K),LABEL,OUTYR,OUTMON) 202 continue C**** C**** Atmospheric Mass (kg/m^2) C**** IF(.not.QMA) GO TO 220 DO 212 I=1,IM*JM MAS = 0. DO 211 L=1,LMA 211 MAS = MAS + AIJL(I,1,L,1) 212 X(I,1) = MAS/IDACCS(4) CALL WRITED (NAMEX(1),LABEL,OUTYR,OUTMON) C**** C**** Water Vapor Mass (kg/m^2) C**** 220 IF(.not.QMWV) GO TO 230 DO 222 J=1,JM DO 222 I=1,IM MWV = 0. DO 221 L=1,LMA 221 MWV = MWV + AIJL(I,J,L,9) 222 X(I,J) = MWV/(IDACCS(4)*DXYP(J)) CALL WRITED (NAMEX(2),LABEL,OUTYR,OUTMON) C**** C**** Sea Level Pressure (mb-1000) C**** 230 IF(.not.QPSL) GO TO 240 BETA = .0065d0 GBYRB = GRAV/(287.*BETA) DO 231 J=1,JM IMAX=IM IF(J.eq.1 .or. J.eq.JM) IMAX=1 DO 231 I=1,IMAX TS = AIJ(I,J,35)/(IDACCS(1)*NSURF) + 273.16d0 PS = AIJ(I,J,14)/ IDACCS(1) + 101325. 231 X(I,J) = 1.d-2*PS*(1.+BETA*ZATMO(I,J)/TS)**GBYRB - 1000. CALL WRITED (NAMEX(3),LABEL,OUTYR,OUTMON) C**** C**** Cloud Top Pressure (mb) C**** 240 IF(.not.QPCT) GO TO 250 DO 241 I=1,IM*JM X(I,1) = -999999. 241 IF(AIJ(I,1,19).gt.0.) X(I,1) = AIJ(I,1,39)/AIJ(I,1,19) CALL WRITED (NAMEX(4),LABEL,OUTYR,OUTMON) C**** C**** Cloud Top Temperature (C) C**** 250 IF(.not.QTCT) GO TO 260 DO 251 I=1,IM*JM X(I,1) = -999999. 251 IF(AIJ(I,1,19).gt.0.) X(I,1) = AIJ(I,1,40)/AIJ(I,1,19) CALL WRITED (NAMEX(5),LABEL,OUTYR,OUTMON) C**** C**** Sea Ice Mass and Snow (kg/m^2) C**** 260 IF(.not.QMSI) GO TO 270 DO 261 I=1,IM*JM X(I,1) = 0. 261 IF(AIJ(I,1,1).gt.0.) X(I,1) = AIJ(I,1,16)/AIJ(I,1,1) CALL WRITED (NAMEX(6),LABEL,OUTYR,OUTMON) C**** C**** Glacial Ice Snow Accumulation (kg/year*m^2) C**** 270 IF(.not.QGISA) GO TO 280 DO 271 I=1,IM*JM 271 X(I,1) = FGICE(I,1)*AIJ(I,1,8)*365.*SDAY/(DTS*IDACCS(1)) CALL WRITED (NAMEX(7),LABEL,OUTYR,OUTMON) C**** C**** Ice or Snow Cover (%) C**** 280 IF(.not.QISC) GO TO 290 DO 281 I=1,IM*JM 281 X(I,1) = (FOCEAN(I,J) *AIJ(I,1,1) + * (1.-FOCEAN(I,J))*AIJ(I,1,2))*100./IDACCS(1) CALL WRITED (NAMEX(8),LABEL,OUTYR,OUTMON) C**** C**** Surface Relative Humidity (%) C**** 290 IF(.not.QRHS) GO TO 300 DO 292 J=1,JM IMAX=IM IF(J.eq.1 .or. J.eq.JM) IMAX=1 DO 292 I=1,IMAX TS = AIJ(I,J,35) /(IDACCS(1)*NSURF) ! degrees Centigrade QS = AIJ(I,J,50) / IDACCS(3) PS = AIJ(I,J,14) / IDACCS(1) + 101325. IF(TS.ge.0.) EL = ELHE + (SHCV-SHCW)*TS IF(TS.lt.0.) EL = ELHS + (SHCV-SHCI)*TS PPVS = PPVSAT(TS+TKF,EL) PPV = RVAP*QS*PS / (RDRY+(RVAP-RDRY)*QS) 292 X(I,J) = 100.*PPV/PPVS CALL WRITED (NAMEX(9),LABEL,OUTYR,OUTMON) C**** C**** Planetary Albedo (%) C**** 300 IF(.not.QALBP) GO TO 310 DO 301 I=1,IM*JM X(I,1) = -999999. 301 IF(AIJ(I,1,25).gt.0.) X(I,1) = 100.*(1.-AIJ(I,1,24)/AIJ(I,1,25)) CALL WRITED (NAMEX(10),LABEL,OUTYR,OUTMON) C**** C**** Surface Albedo (%) C**** 310 IF(.not.QALBS) GO TO 320 DO 311 I=1,IM*JM X(I,1) = -999999. 311 IF(AIJ(I,1,27).gt.0.) X(I,1) = 100.*(1.-AIJ(I,1,26)/AIJ(I,1,27)) CALL WRITED (NAMEX(11),LABEL,OUTYR,OUTMON) C**** C**** Net Heating at Surface (W/m^2) C**** 320 IF(.not.QNHS) GO TO 330 DO 321 I=1,IM*JM 321 X(I,1) = (AIJ(I,1,57) + AIJ(I,1,58) + AIJ(I,1,59)*FGICE(I,1) + * AIJ(I,1,60)*FGRND(I,1) + AIJ(I,1,52)) / (DTS*IDACCS(1)) CALL WRITED (NAMEX(12),LABEL,OUTYR,OUTMON) C**** C**** Diurnal Surface Air Temperature Variation (C) C**** 330 IF(.not.QTSADV) GO TO 340 DO 331 I=1,IM*JM 331 X(I,1) = (AIJ(I,1,11) - AIJ(I,1,10)) / IDACCS(12) CALL WRITED (NAMEX(13),LABEL,OUTYR,OUTMON) C**** C**** Diurnal Ground Temperature Variation (C) C**** 340 IF(.not.QTGDV) GO TO 350 DO 341 I=1,IM*JM 341 X(I,1) = (AIJ(I,1,13) - AIJ(I,1,12)) / IDACCS(12) CALL WRITED (NAMEX(14),LABEL,OUTYR,OUTMON) C**** C**** Standard Deviation of Daily Precipitation (mm/day) C**** 350 IF(.not.QPRESD) GO TO 360 DO 351 I=1,IM*JM PRECM = AIJ(I,1,5) / IDACCS(12) ! average of daily precip PRECV = AIJ(I,1,73) / IDACCS(12) ! average of (daily precip)^2 351 X(I,1) = SQRT(PRECV - PRECM*PRECM) CALL WRITED (NAMEX(15),LABEL,OUTYR,OUTMON) C**** C**** Standard Deviation of Daily Surface Air Temperature (C) C**** 360 IF(.not.QTSASD) GO TO 370 DO 361 I=1,IM*JM TSAM = AIJ(I,1,35) / (IDACCS(1)*NSURF) ! average of daily TSA TSAV = AIJ(I,1,74) / (IDACCS(1)*NSURF*NSURF*NDAY) ! (daily TSA)^2 361 X(I,1) = SQRT(TSAV - TSAM*TSAM) CALL WRITED (NAMEX(16),LABEL,OUTYR,OUTMON) C**** C**** Standard Deviation of Daily Surface Pressure (mb) C**** 370 IF(.not.QPSSD) GO TO 380 DO 371 I=1,IM*JM PSM = AIJ(I,1,14) / IDACCS(1) ! average of daily PS PSV = AIJ(I,1,75) /(IDACCS(1)*NDAY) ! average of (daily PS)^2 371 X(I,1) = 1.d-2*SQRT(PSV - PSM*PSM) CALL WRITED (NAMEX(17),LABEL,OUTYR,OUTMON) C**** C**** Converged sea ice mass flux (kg/day*m^2) C**** 380 IF(.not.QCSIM) GO TO 390 Im1 = IM DO 381 J=2,JM-1 DO 381 I=1,IM X(I,J) = (AIJ(Im1,J,30)-AIJ(I,J,30) + AIJ(I,J-1,31)-AIJ(I,J,31))* * NDAY / (IDACC(1)*DXYP(J)) 381 Im1 = I X(1,1) = 0. X(1,JM)= 0. DO 382 I=1,IM 382 X(1,JM) = X(1,JM) + AIJ(I,JM-1,31) X(1,JM) = X(1,JM)*NDAY / (IDACC(1)*DXYP(JM)*IM) CALL WRITED (NAMEX(18),LABEL,OUTYR,OUTMON) C**** C**** Converged sea ice velocity (1/day) C**** 390 IF(.not.QCSIV) GO TO 400 Im1 = IM-1 I = IM DO 391 J=2,JM-1 DO 391 Ip1=1,IM X(I,J) = (DYP(J) *AIJ(Im1,J,67)/(AIJ(Im1,J,1)+AIJ(I,J,1)) - - DYP(J) *AIJ(I ,J,67)/(AIJ(Ip1,J,1)+AIJ(I,J,1)) + + DXV(J-1)*AIJ(I,J-1,68)/(AIJ(I,J-1,1)+AIJ(I,J,1)) - - DXV(J) *AIJ(I,J ,68)/(AIJ(I,J+1,1)+AIJ(I,J,1)))*SDAY / / DXYP(J) Im1 = I 391 I = Ip1 X(1,1) = 0. X(1,JM)= 0. CALL WRITED (NAMEX(19),LABEL,OUTYR,OUTMON) C**** C**** Geopotential Height (m) C**** 400 DO 450 K=1,KHMAX IF(.not.QH(K)) GO TO 450 DO 440 J=1,JM IMAX=IM IF(J.eq.1 .or. J.eq.JM) IMAX=1 DO 440 I=1,IMAX MAS = 0. DO 410 L=1,LMA 410 MAS = MAS + AIJL(I,J,L,1) MAS = MAS/IDACCS(4) + MSTRAT ZG = GRAV*ZATMO(I,J) PKD = (GRAV*MAS)**RKAP L = 1 420 MAS = MAS - AIJL(I,J,L,1)/IDACCS(4) IF(GRAV*MAS .le. 100.*RH(K)) GO TO 430 PKU = (GRAV*MAS)**RKAP ZG = ZG + (PKD-PKU)*AIJL(I,J,L,5) / (AIJL(I,J,L,1)*DXYP(J)) L = L + 1 PKD = PKU GO TO 420 430 PKU = (100.*RH(K))**RKAP ZG = ZG + (PKD-PKU)*AIJL(I,J,L,5) / (AIJL(I,J,L,1)*DXYP(J)) 440 X(I,J) = ZG/GRAV - DH(K) NAMEX(20)(1:4) = CH(K) IF(K.gt.1) WRITE (NAMEX(20)(31:37),944) INT(DH(K)) CALL WRITED (NAMEX(20),LABEL,OUTYR,OUTMON) 450 continue C**** 500 CLOSE (2) CLOSE (6) GO TO 999 C**** 800 WRITE (0,*) 'Usage: AIJ070 /raid1/C070/DJa* ', * 'Make atmosphere IxJ data files' WRITE (0,*) 'Check the input file: AIJ070.I 1999/09/20' 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**** 911 FORMAT (' From',I6,A5,' to',I6,A5,' FILEIN=',A) 944 FORMAT ('-',I5,')') 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 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 AIJ070: inconsistant year and months received' WRITE (0,*) 'From AIJ070: 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 a record to a data file whose format is: TITLE(80),A(IM,JM) C**** Input: NAME = name of quantity C**** LABEL = run number C**** OUTMON = month C**** OUTYR = year C**** PARAMETER (IM=72,JM=46) REAL*8 Q CHARACTER NAME*50,LABEL*5,OUTYR*4,OUTMON*4, TITLE*80 COMMON Q(IM,JM) C**** Replicate I=1 value to all longitudes at the poles DO 10 I=2,IM Q(I, 1) = Q(1, 1) 10 Q(I,JM) = Q(1,JM) C**** Build TITLE WRITE (TITLE,901) NAME,LABEL,OUTYR,OUTMON C**** Write record to disk WRITE (2) TITLE,(SNGL(Q(I,1)),I=1,IM*JM) WRITE (6,902) TITLE,(Q(IM/2+1,J),J=1,JM) RETURN C**** 901 FORMAT (A50,A5,9X,A4,1X,A3) 902 FORMAT ('0',A72/(12F11.3)) END SUBROUTINE READR4 (IUNIT,NM,DATAR4,DATAR8) C**** C**** READR4 reads a record from unit IUNIT containing TITLE,DATAR4, C**** converts the REAL*4 array DATAR4 to the REAL*8 array DATAR8, and C**** writes a line to unit 6 containing the TITLE just read. C**** REAL*4 DATAR4(NM) REAL*8 DATAR8(NM) CHARACTER*80 TITLE C**** READ (IUNIT) TITLE,DATAR4 DO 10 I=NM,1,-1 10 DATAR8(I) = DATAR4(I) WRITE (6,901) IUNIT,TITLE RETURN C**** 901 FORMAT (' Read on unit',I3,': ',A80) END BLOCK DATA C**** C**** Contents of latitude by longitude arrays C**** PARAMETER (KAIJ=76) CHARACTER*50 NAME,NAMEX COMMON /NAMECB/ NAME(KAIJ), NAMEX(20) C**** DATA NAME / 1'OCEAN ICE COVER (%)', 2'SNOW COVER (%)', 3'SNOW DEPTH (kg/m^2)', 4'SENSIBLE HEAT FLUX (W/m^2)', 5'PRECIPITATION (mm/day)', 6'EVAPORATION (mm/day)', 7'GROUND WETNESS over GROUND (%)', 8'SNOW ACCUMULATION over GLACIAL ICE (kg/year*m^2)', 9'ENERGY from GLACIAL ICE COMPRESSING (W/m^2)', 1O'DAILY MINIMUM SURFACE AIR TEMPERATURE (C)', 11'DAILY MAXIMUM SURFACE AIR TEMPERATURE (C)', 12'DAILY MINIMUM GROUND TEMPERATURE (C)', 13'DAILY MAXIMUM GROUND TEMPERATURE (C)', 14'SURFACE PRESSURE (mb-1013.25)', 15'CONVECTIVE PRECIPITATION (mm/day)', 16'SEA ICE MASS * FWICE (kg/m^2)', 17'SOIL MOISTURE over GROUND (cm)', 18'VERTICALLY INTEGRATED OPTICAL DEPTH', 19'TOTAL CLOUD COVER (%)', 2O'ENERGY OUTFLOW by RIVERS (10^10 W)', 21'OUTGOING THERMAL RADIATION of PLANET (W/m^2)', 22'NET THERMAL RADIATION at SURFACE (W/m^2)', 23'NET HEATING at SURFACE (W/m^2)', 24'ABSORBED SOLAR RADIATION of PLANET (W/m^2)', 25'INCIDENT SOLAR RADIATION of PLANET (W/m^2)', 26'ABSORBED SOLAR RADIATION at SURFACE (W/m^2)', 27'INCIDENT SOLAR RADIATION at SURFACE (W/m^2)', 28'GROUND TEMPERATURE (C) of Layer 1', 29'OCEAN SURFACE HEIGHT (cm)', 3O'EASTWARD SEA ICE MASS FLUX (10^6 kg/s)', 31'NORTHWARD SEA ICE MASS FLUX (10^6 kg/s)', 32'AERODYNAMIC POTENTIAL EVAPORATION (mm/day)', 33'PENMAN POTENTIAL EVAPORATION (mm/day)', 34'MASS OUTFLOW by RIVERS (10^5 kg/s)', 35'SURFACE AIR TEMPERATURE (C)', 36'U COMPONENT of SURFACE AIR WIND (m/s)', 37'V COMPONENT of SURFACE AIR WIND (m/s)', 38'SEA ICE PRESSURE (mb)', 39'CLOUD TOP PRESSURE (mb) times CLOUD COVER', 4O'CLOUD TOP TEMPERATURE (K) times CLOUD COVER', 41'CLOUD COVER (%) from Layers 1, 2 and 3', 42'CLOUD COVER (%) from Layers 4 and 5', 43'CLOUD COVER (%) from Layers 6 and 7', 44'SURFACE RUNOFF over GROUND (mm/day)', 45'UNDERGROUND RUNOFF over GROUND (mm/day)', 46'SURFACE RUNOFF over GLACIAL ICE (mm/day)', 47'SURFACE CROSS ISOBAR ANGLE, ALPHA0 (degrees)', 48'U COMPONENT of SURFACE MOMENTUM STRESS (N/m^2)', 49'V COMPONENT of SURFACE MOMENTUM STRESS (N/m^2)', 5O'SURFACE AIR SPECIFIC HUMIDITY (g/kg)', 51'SURFACE WIND SPEED (m/s)', 52'ENERGY of PRECIPITATION (W/m^2)', 53'EVAPORATION times FOWATR (mm/day)', 54'EVAPORATION times FWICE (mm/day)', 55'EVAPORATION over GLACIAL ICE (mm/day)', 56'EVAPORATION over GROUND (mm/day)', 57'NET HEAT at SURFACE times FOWATR (W/m^2)', 58'NET HEAT at SURFACE times FWICE (W/m^2)', 59'NET HEAT at SURFACE over GLACIAL ICE (W/m^2)', 6O'NET HEAT at SURFACE over GROUND (W/m^2)', 61'SEA ICE MASS FORMED (kg/day*m^2)', 62'SEA ICE ENERGY FORMED (W/m^2)', 63'SEA ICE MASS MELTED (kg/day*m^2)', 64'SEA ICE ENERGY MELTED (W/m^2)', 65'ICE BERG MASS MELTED (kg/day*m^2)', 66'ICE BERG ENERGY MELTED (W/m^2)', 67'U COMPONENT of SEA ICE VELOCITY (m/s) * FWICE', 68'V COMPONENT of SEA ICE VELOCITY (m/s) * FWICE', 69'U COMPONENT of SEA ICE MOMENTUM STRESS (N/m^2) *', 7O'V COMPONENT of SEA ICE MOMENTUM STRESS (N/m^2) *', 71'SHALLOW CONVECTIVE FREQUENCY (%)', 72'DEEP CONVECTIVE FREQUENCY (%)', 73'VARIANCE of DAILY PRECIPITATION (mm/day)^2', 74'VARIANCE of DAILY SURFACE AIR TEMPERATURE (C)^2', 75'VARIANCE of DAILY SURFACE PRESSURE (mb)^2', 76'TURBULENT KINETIC ENERGY LOST at SURFACE (W/m^2)'/ C**** DATA NAMEX / 1'ATMOSPHERIC MASS (kg/m^2)', 2'WATER VAPOR MASS (kg/m^2)', 3'SEA LEVEL PRESSURE (mb-1000)', 4'CLOUD TOP PRESSURE (mb)', 5'CLOUD TOP TEMPERATURE (K)', 6'SEA ICE MASS and SNOW (kg/m^2)', 7'GLACIAL ICE SNOW ACCUMULATION (kg/year*m^2)', 8'ICE or SNOW COVER (%)', 9'SURFACE RELATIVE HUMIDITY (%)', 1O'PLANETARY ALBEDO (%)', 11'SURFACE ALBEDO (%)', 12'NET HEATING at SURFACE (W/m^2)', 13'DIURNAL SURFACE AIR TEMPERATURE VARIATION (C)', 14'DIURNAL GROUND TEMPERATURE VARIATION (C)', 15'STAN.DEV. of DAILY PRECIPITATION (mm/day)', 16'STAN.DEV. of DAILY SURFACE AIR TEMPERATURE (C)', 17'STAN.DEV. of DAILY SURFACE PRESSURE (mb)', 18'CONVERGED SEA ICE MASS (kg/day*m^2)', 19'CONVERGED SEA ICE VELOCITY (1/day)', 2O'1000 mb GEOPOTENTIAL HEIGHT (m)'/ END