C**** DIURN070.S print GCM Diurnal DIAGnostics from DIAGD 98/07/22 C**** C**** DIURN070 reads several Climate Model III Diagnostic Files, C**** averages the data, and calls GCM subroutines DIAGD. 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**** CHARACTER FILEIN*80, TITLE*80, OUTYR*4,OUTMON*4, NAME*8 INTEGER*4 IDACCS(15), NDIURN(0:24) REAL*8 SCALE(50),DIURN(0:24) COMMON /DIURCB/ NAME(50) DATA SCALE/1.,2*100.,2*1., .01,4*1., 3*1.,2*1.E5, 5*1.E5, * 5*100., 2*100.,3*1., 2*1.,3*10., 3*10.,1.,100., * 100.,2*1.E4,2*10., .01,100.,10.,2*1./ C**** NARGS = IARGC() IF(IARGC().le.0) GO TO 800 OPEN (6,FILE='DIURN070.PRT') C**** Read first input file to determine KOLNS0 and KDACCX CALL GETARG (1,FILEIN) OPEN (1,FILE=FILEIN,FORM='UNFORMATTED',STATUS='OLD',ERR=810) READ (1) IHOURX,LABEL,IPARM CLOSE (1) KAIJL0 = JM*KAJ$*6 + JM*LMA$*KAJL$ + JM*3*4 + IM*JM*KAIJ$ KOLNS0 = KAIJL0 + IM*JM*LMA$*KAIJL$ + IM*JM*LMO$*KOIJL$ + * LMO$*NMST$*KOLNS$ KDACCX = KOLNS0 + 24*50*4 + JM*KCON$ WRITE (6,*) 'KDINT,KDACCX =',KDINT,KDACCX C**** Calculate spherical geometry CALL SGEOM C**** C**** Zero out summing arrays C**** DO 10 N=1,15 10 IDACCS(N) = 0 DO 20 I=1,IM*JM*LMA$ 20 AIJL(I,1,1,1) = 0. DO 30 KQ=1,50*4 DO 30 IH=0,23 30 ADAILY(IH,KQ,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 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 110 N=1,15 110 IDACCS(N) = IDACCS(N) + IDACC(N) DO 120 I=1,IM*JM*LMA$ 120 AIJL(I,1,1,1) = AIJL(I,1,1,1) + DIAGR4(KAIJL0+I) DO 130 KQ=1,50*4 DO 130 IH=0,23 130 ADAILY(IH,KQ,1) = ADAILY(IH,KQ,1) + DIAGR4(KOLNS0+1+IH+(KQ-1)*24) GO TO 100 C**** C**** End of input files: print table of input months and years C**** 200 CALL PRNTYM (OUTYR,OUTMON) C**** C**** Calculate constant scaling factors C**** SCALE( 5) = NSURF/DTS SCALE(28) = NSURF/DTS SCALE(29) = NSURF/DTS SCALE(30) = NSURF/DTS SCALE(31) = NSURF/DTS SCALE(32) = NSURF/DTS SCALE(39) = 360./TWOPI SCALE(49) = 100.*NDAY SCALE(50) = 100.*SDAY*NSURF/DTS C**** C**** Loop over the 4 grid boxes C**** Calculate scaling factors that depend on grid box mass C**** DO 390 KR=1,4 I = IJDD(1,KR) J = IJDD(2,KR) WRITE (6,930) LABEL, NAMDD(KR),I,J,OUTYR,OUTMON, (IH,IH=0,23) SCALE( 7) = IDACCS(4)/(DXYP(J)*AIJL(I,J,5,1)*SHCD) SCALE( 8) = IDACCS(4)/(DXYP(J)*AIJL(I,J,4,1)*SHCD) SCALE( 9) = IDACCS(4)/(DXYP(J)*AIJL(I,J,3,1)*SHCD) SCALE(10) = IDACCS(4)/(DXYP(J)*AIJL(I,J,2,1)*SHCD) SCALE(11) = IDACCS(4)/(DXYP(J)*AIJL(I,J,1,1)*SHCD) SCALE(14) = 1.d5*IDACCS(4)/(DXYP(J)*AIJL(I,J,5,1)) SCALE(15) = 1.d5*IDACCS(4)/(DXYP(J)*AIJL(I,J,4,1)) SCALE(16) = 1.d5*IDACCS(4)/(DXYP(J)*AIJL(I,J,3,1)) SCALE(17) = 1.d5*IDACCS(4)/(DXYP(J)*AIJL(I,J,2,1)) SCALE(18) = 1.d5*IDACCS(4)/(DXYP(J)*AIJL(I,J,1,1)) C**** C**** Loop over individual quantities C**** DO 390 KQ=1,50 IF(KQ.eq.48) GO TO 320 C**** Normal quantities AVE = 0. DO 310 IH=0,23 AVE = AVE + ADAILY(IH,KQ,KR) 310 DIURN(IH) = ADAILY(IH,KQ,KR)*SCALE(KQ)*24./IDACCS(1) DIURN(24) = AVE*SCALE(KQ)/IDACCS(1) GO TO 350 C**** Ratio of two quantities 320 AVEN = 0. AVED = 0. DO 330 IH=0,23 AVEN = AVEN + ADAILY(IH,KQ,KR) AVED = AVED + ADAILY(IH,KQ-1,KR) 330 DIURN(IH) = ADAILY(IH,KQ,KR)*SCALE(KQ)/(ADAILY(IH,KQ-1,KR)+1.d-20) DIURN(24) = AVEN*SCALE(KQ)/(AVED+1.d-20) C**** 350 DO 360 IS=0,24 360 NDIURN(IS) = NINT(DIURN(IS)) 390 WRITE (6,939) NAME(KQ),NDIURN CLOSE (6) GO TO 999 C**** 800 WRITE (0,*) 'Usage: DIURN070 /raid2/C078/DJan199* ', * 'print DIAGD 98/07/22' 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) 930 FORMAT ('1',A132 / '0Diurnal Diagnostics Grid Box:',A5,1X,2I4, * ' Year:',A5,' Month:',1X,A3 / * '0',7X,24I5,' Ave') 939 FORMAT (A8,25I5) 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 AIJK070: inconsistant year and months received' WRITE (0,*) 'From AIJK070: 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 BLOCK DATA DIURBD C**** C**** Titles for subroutine DIURN C**** CHARACTER*8 NAME COMMON /DIURCB/ NAME(50) DATA NAME/ * '0Inc SW ',' P Albd ',' G Albd ',' Abs Atm',' E Cnds ', * '0Srf Prs',' PT 5 ',' PT 4 ',' PT 3 ',' PT 2 ', * ' PT 1 ',' TS ',' TG1 ','0Q 5 ',' Q 4 ', * ' Q 3 ',' Q 2 ',' Q 1 ',' QS ',' QG ', * '0Cld 6 ',' Cld 5 ',' Cld 4 ',' Cld 3 ',' Cld 2 ', * ' Cld 1 ',' Cover ','0SW on G',' LW AT G',' Snsb Ht', * ' Lat Ht ',' Heat Z0','0UG*10 ',' VG*10 ',' WG*10 ', * ' US*10 ',' VS*10 ',' WS*10 ',' ALPHA0 ','0RiS1*E2', * ' RiGS*E2',' CDM*E4 ',' CDH*E4 ',' DGS*10 ',' EDS1*10', * '0PPBL ',' DC Freq',' LDC*10 ','0Prc*10 ',' Evp*10 '/ END