From c79093949f6d3c252bc3f1b9abf7e6cf6c4e09e5 Mon Sep 17 00:00:00 2001 From: nicholasesposito Date: Fri, 28 Apr 2023 17:23:36 +0000 Subject: [PATCH 1/2] NST and MAXOBS fixes --- sorc/prepobs_cqcbufr.fd/cqcbufr.f | 172 +++++++++++++++++++----------- sorc/prepobs_cqcbufr.fd/radcor.f | 22 ++-- 2 files changed, 125 insertions(+), 69 deletions(-) diff --git a/sorc/prepobs_cqcbufr.fd/cqcbufr.f b/sorc/prepobs_cqcbufr.fd/cqcbufr.f index 0a12ac6..1e7b710 100644 --- a/sorc/prepobs_cqcbufr.fd/cqcbufr.f +++ b/sorc/prepobs_cqcbufr.fd/cqcbufr.f @@ -334,6 +334,7 @@ PROGRAM PREPOBS_CQCBUFR & WRT23 CALL W3TAGB('PREPOBS_CQCBUFR',2020,0009,0067,'NP22') + print *, "NNNEEE W3TAGB done" TEST = .TRUE. ! Set .T. for tests to give more print !!! #### BE CAREFUL ##### in subr. POBERR, @@ -358,11 +359,15 @@ PROGRAM PREPOBS_CQCBUFR C REAL*8 (or REAL*4) variable that is missing is NINT'd C ------------------------------------------------------------------- CALL ISETPRM ( 'MXMSGL', 600000 ) ! CH 08/31/21 + print *, "NNNEEE ISETPRM done" CALL ISETPRM ( 'MAXSS', 600000 ) ! CH 08/31/21 + print *, "NNNEEE ISETPRM2 done" ccccc CALL SETBMISS(10E10_8) CALL SETBMISS(10E8_8) + print *, "NNNEEE SETBMISS done" BMISS=GETBMISS() CALL MAXOUT(50000) ! CH 08/31/21 + print *, "NNNEEE MAXOUT(50000) done" XMISS=BMISS IMISS=10E8 print * @@ -370,6 +375,7 @@ PROGRAM PREPOBS_CQCBUFR print * CALL ACCUM + print *, "NNNEEE ACCUM done" START = .TRUE. ! Input opens data file when START=.T. ENDIN = .FALSE. ! Initialize SKIP = .FALSE. ! Initialize @@ -383,6 +389,7 @@ PROGRAM PREPOBS_CQCBUFR IF(SINGLE) THEN CALL SETTMP + print *, "NNNEEE SETTMP done" GOTO 300 ENDIF @@ -390,29 +397,43 @@ PROGRAM PREPOBS_CQCBUFR C --------------------------------------------- 100 CONTINUE + print *, "NNNEEE 100 BEGINS" ITIME = 1 WRITE(60,520) START,ENDIN,SKIP,SAME,WIND,ITIME,USESQN 520 FORMAT(' MAIN--START,ENDIN,SKIP,SAME,WIND,ITIME,USESQN: ', & 5(L2,2X),I5,2X,L2) CALL INPUT(START,ENDIN,SKIP,SAME,WIND,ITIME,USESQN) + print *, "NNNEEE INPUT DONE" ! Read data for 1 station IF(ENDIN) GOTO 200 IF(SKIP .OR. WIND) GOTO 100 CALL RESIDS(ITIME) ! Calculate all but horizontal resids + print *, "NNNEEE RESIDS DONE" CALL ISGOOD ! Preliminary quality assessment + print *, "NNNEEE ISGOOD DONE" GOTO 100 200 CONTINUE + print *, "NNNEEE 200 BEGINS" IF(DOTMP) THEN + print *, "NNNEEE DOTMP BEGINS" CALL INPUT2 ! Read data for temporal check + print *, "NNNEEE DOTMP INPUT2 done" CALL TMPCHK ! Perform temporal check + print *, "NNNEEE DOTMP TMPCHK done" ELSE + print *, "NNNEEE NOTDOTMP BEGINS" CALL SETTMP + print *, "NNNEEE SETTMP done" + ENDIF CALL HORRES ! Calculate horizontal residuals + print *, "NNNEEE HORRES done" CALL STAT(ITIME) ! Calculate & print statistics + print *, "NNNEEE STAT done" CALL XHORRES ! Calc normalized horizontal residuals + print *, "NNNEEE XHORRES done" START = .TRUE. @@ -420,6 +441,7 @@ PROGRAM PREPOBS_CQCBUFR C ---------------------------------------- 300 CONTINUE + print *, "NNNEEE 300 BEGINS" ITIME = 2 ISC = 0 LAST = 0 @@ -428,63 +450,91 @@ PROGRAM PREPOBS_CQCBUFR IF(.NOT.SINGLE) THEN CALL INPUT(START,ENDIN,SKIP,SAME,WIND,ITIME,USESQN) ! Read data a 2nd time, 1 rpt at a time + print *, "NNNEEE NOT SINGLE INPUT done" ELSE CALL RBLOCKS(SKIP,WIND,ENDIN) + print *, "NNNEEE RBLOCKS done" ENDIF IF(ENDIN) GOTO 600 IF(SKIP) GOTO 500 IF(WIND) THEN + print *, "NNNEEE WIND BEGINS" CALL INCRW + print *, "NNNEEE WIND INCRW done" CALL PRSTNS(WIND) + print *, "NNNEEE WIND PRSTNS done" GOTO 500 ENDIF CALL CKPS + print *, "NNNEEE CKPS done" CALL RESIDS(ITIME) + print *, "NNNEEE RESIDS done" CALL PRSTNS(WIND) + print *, "NNNEEE ANOTHER PRSTNS done" ICALL = 3 CALL PRNTOUT(SEQQ,ICALL) + print *, "NNNEEE PRNTOUT done" C LOOP THROUGH LEVELS UNTIL TOP IS REACHED C ---------------------------------------- 400 CONTINUE ISC = ISC + 1 + print *, "NNNEEE 400 begins" CALL DMA(ANY,OBS) ! Decision Making Algorithm + print *, "NNNEEE DMS DONE" CALL CHANGE(ANY,SINGLE,SEQQ) ! Apply corrs to the data + print *, "NNNEEE CHANGE DONE" IF(ANY) ANYS = .TRUE. CALL RESIDS(ITIME) + print *, "NNNEEE ANOTHER RESIDS done" IF(ANY) CALL DHOR ! Calculate changes to hor resids IF((ANY .OR. .NOT.OBS .OR. LAST.LT.NLEV) .AND. ISC.LT.30) GOTO 400 CALL STEVNTS ! Print BUFR events for single stn + print *, "NNNEEE STEVNTS done" ICALL = 1 IF(ANYS .AND. OBS) CALL PRNTOUT(SEQQ,ICALL) CALL MASEVN ! Write CQC mass events + print *, "NNNEEE MASEVN done" 500 CONTINUE CALL AUXLEVS(SKIP,SAME,WIND,SINGLE,ANYS) + print *, "NNNEEE AUXLEVS done" IF(.NOT.WIND) THEN + print *, "NNNEEE NOT WIND AA begins" CALL RADEVN ! Write radiation correction events + print *, "NNNEEE NOT WIND RADEVN done" CALL VTPEVN(DOVTMP) ! Write virtual temperature events + print *, "NNNEEE NOT WIND VTPEVN(DOVTMP) done" ENDIF CALL OUTPUT(ENDIN,SINGLE) + print *, "NNNEEE OUTPUT AAAA ends" GOTO 300 ! Go back for the next report C END OF DATA REACHED C ------------------- 600 CONTINUE + print *, "NNNEEE 600 BEGINS" CALL STAT(ITIME) + print *, "NNNEEE STAT done" CALL PEVENTS ! Print events + print *, "NNNEEE PEVENTS done" IF(.NOT.SINGLE) CALL STNCNT ! Print counts by WMO block + print *, "NNNEEE STNCNT done" I2 = IEVENT ICALL = 2 CALL EVPROC(1,I2,ICALL) ! Generate, print BUFR events + print *, "NNNEEE EVPROC done" CALL WTSTATS ! Write statistics for RADCOR + print *, "NNNEEE WTSTATS done" CALL WTISO + print *, "NNNEEE WTISO done" CALL CLOSBF(NFIN) + print *, "NNNEEE CLOSBF done" CALL CLOSBF(NFOUT) - + print *, "NNNEEE CLOSBF2 done" CALL W3TAGE('PREPOBS_CQCBUFR') - + print *, "NNNEEE W3TAGE2 done" STOP END C********************************************************************** @@ -927,7 +977,7 @@ SUBROUTINE AREA(IA,X,Y) C$$$ SUBROUTINE AUXLEVS(SKIP,SAME,WIND,SINGLE,ANYS) - PARAMETER (NST=999) + PARAMETER (NST=2499) COMMON /HEADER/ SID(NST), DHR(NST), XOB(NST), YOB(NST), & ELV(NST), SQN(NST), ITP(NST), NLV, @@ -1127,7 +1177,7 @@ SUBROUTINE CHANGE(ANY,SINGLE,SEQLP) REAL(8) BMISS SAVE IEVOLD - PARAMETER (NST=999) + PARAMETER (NST=2499) COMMON /HEADER/ SID(NST), DHR(NST), XOB(NST), YOB(NST), & ELV(NST), SQN(NST), ITP(NST), NLV, & NEV, ISF(NST), NLVM, NLVW @@ -1691,7 +1741,7 @@ SUBROUTINE CHKTMP(A,C,R,ICK) C$$$ SUBROUTINE CKPS - PARAMETER (NST=999) + PARAMETER (NST=2499) COMMON /HEADER/ SID(NST), DHR(NST), XOB(NST), YOB(NST), & ELV(NST), SQN(NST), ITP(NST), NLV, @@ -1790,7 +1840,7 @@ SUBROUTINE CKPS C$$$ SUBROUTINE COMPER(L,LM) - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -2280,7 +2330,7 @@ SUBROUTINE DHOR REAL(8) BMISS SAVE IEVOLD - PARAMETER (NST=999) + PARAMETER (NST=2499) COMMON /MANRES/ ZIM(21,NST),TIM(21,NST),TDIM(21,NST),QIM(21,NST), & ZHM(21,NST),THM(21,NST),TDHM(21,NST),QHM(21,NST), & ZVM(21,NST),TVM(21,NST),TDVM(21,NST),QVM(21,NST), @@ -2408,7 +2458,7 @@ SUBROUTINE DHOR SUBROUTINE DISTR(X,MSK,XLIM,XMSG,NX,N,NDIV,DDIV, & NZERO,DZERO,NS,X1,SD,SK,XK) - PARAMETER (NST=999) + PARAMETER (NST=2499) INTEGER N(23), MSK(NST) REAL X(NST),XLIM(2) @@ -2517,7 +2567,7 @@ SUBROUTINE DISTR(X,MSK,XLIM,XMSG,NX,N,NDIV,DDIV, C$$$ SUBROUTINE DMA(ANY,OBS) - PARAMETER (NST=999) + PARAMETER (NST=2499) COMMON /HEADER/ SID(NST), DHR(NST), XOB(NST), YOB(NST), & ELV(NST), SQN(NST), ITP(NST), NLV, & NEV, ISF(NST), NLVM, NLVW @@ -2752,7 +2802,7 @@ SUBROUTINE DRCTSL(FAALL,RAALL,DOTPRD,NDIM,MAXDIM,NXXYY,NFT,LEV,IV) C$$$ SUBROUTINE ERR123(L,LM) - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -3289,7 +3339,7 @@ SUBROUTINE ERR123(L,LM) C$$$ SUBROUTINE ERR5(L,LM) - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -3583,7 +3633,7 @@ SUBROUTINE ERR5(L,LM) C$$$ SUBROUTINE ERR710(L,LM) - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -4211,7 +4261,7 @@ SUBROUTINE ERR710(L,LM) C$$$ SUBROUTINE ERRTYP - PARAMETER (NST=999) + PARAMETER (NST=2499) COMMON /HEADER/ SID(NST), DHR(NST), XOB(NST), YOB(NST), & ELV(NST), SQN(NST), ITP(NST), NLV, @@ -4569,7 +4619,7 @@ SUBROUTINE EVENTW(LUNIT,EVNSTR,NLV,OBS,QMS,RCS,IND,NEVN,QCPC) C$$$ SUBROUTINE EVPROC(I1,I2,ICALL) - PARAMETER (NST=999) + PARAMETER (NST=2499) COMMON /EVENTS/ STN(2000), SEQN(2000), ISCAN(2000), & LEVL(2000), PRES(2000), LTYP(2000), @@ -4831,7 +4881,7 @@ SUBROUTINE EVPROC(I1,I2,ICALL) C$$$ SUBROUTINE FILALL(SAME,WIND) - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -5260,7 +5310,7 @@ SUBROUTINE FILL(OBS,NLEV) C C$$$ SUBROUTINE FULVAL(WIND) - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -5613,7 +5663,7 @@ SUBROUTINE FUZZY(P,XI,XV,XH,B,PER) C$$$ SUBROUTINE GETINC(WIND) - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -5799,7 +5849,7 @@ SUBROUTINE GETINC(WIND) C SUBROUTINE GETLEV(WIND) - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -6194,7 +6244,7 @@ SUBROUTINE GETPS(PS,ZS,Z1,T1,P1) C$$$ SUBROUTINE HOLES - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -6287,7 +6337,7 @@ SUBROUTINE HOLES C$$$ SUBROUTINE HORRES - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -6540,7 +6590,7 @@ SUBROUTINE HORRES C$$$ SUBROUTINE HSC - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -6809,7 +6859,7 @@ SUBROUTINE HSC C$$$ SUBROUTINE INCR(ITIME) - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -7037,7 +7087,7 @@ SUBROUTINE INCR(ITIME) C$$$ SUBROUTINE INCRW - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -7128,7 +7178,7 @@ SUBROUTINE INCRW C C$$$ SUBROUTINE INIT - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -7211,7 +7261,7 @@ SUBROUTINE INIT SUBROUTINE INPUT(START,ENDIN,SKIP,SAME,WIND,ITIME,USESQN) SAVE - PARAMETER (NST=999) ! maximum number of stations + PARAMETER (NST=2499) ! maximum number of stations PARAMETER (MVO=5) ! p,T,z,q,Td PARAMETER (MLV=255) ! number of possible levels PARAMETER (MEV=13) ! number of possible programs/events @@ -7414,6 +7464,7 @@ SUBROUTINE INPUT(START,ENDIN,SKIP,SAME,WIND,ITIME,USESQN) ENDIF IF(IS+1.GT.NST) THEN + PRINT *, "NNNEEE IS= ", IS PRINT *, 'MAXOBS (NST) EXCEEDED IN INPUT - STOP 99' CALL W3TAGE('PREPOBS_CQCBUFR') CALL ERREXIT(99) @@ -7786,7 +7837,7 @@ SUBROUTINE INPUT(START,ENDIN,SKIP,SAME,WIND,ITIME,USESQN) C$$$ SUBROUTINE INPUT2 - PARAMETER(NST=999) + PARAMETER(NST=2499) REAL(8) BMISS,RIT_8,HDR_8(10),UPA_8(10,255) @@ -7990,7 +8041,7 @@ SUBROUTINE INPUT2 C$$$ SUBROUTINE ISGOOD - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -8236,7 +8287,7 @@ SUBROUTINE ISGOOD C C$$$ SUBROUTINE ISOLAT(ID) - PARAMETER (NST=999) + PARAMETER (NST=2499) C C COLLECT LIST OF ISOLATED STATIONS. @@ -8297,7 +8348,7 @@ SUBROUTINE ISORT(IA,INDX,N) C SORT IA ACCORDING TO THE ORDER SPECIFIED BY THE C INDICES IN INDX. - PARAMETER (NST=999) + PARAMETER (NST=2499) DIMENSION IA(*), IKSP(NST) INTEGER INDX(*) DO J=1,N @@ -8336,7 +8387,7 @@ SUBROUTINE ISORT(IA,INDX,N) C$$$ SUBROUTINE LAPSE - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -8458,7 +8509,7 @@ SUBROUTINE LAPSE C$$$ SUBROUTINE LEVTYPS - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -8761,7 +8812,7 @@ FUNCTION MANLEV(P) C C$$$ SUBROUTINE MASEVN - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -9172,7 +9223,7 @@ FUNCTION NMANLV(P) C$$$ SUBROUTINE NOBERR - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -9397,7 +9448,7 @@ SUBROUTINE NOBERR C$$$ SUBROUTINE OBERR - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -9989,7 +10040,7 @@ SUBROUTINE PEVENTS C$$$ SUBROUTINE POBERR - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -10257,7 +10308,7 @@ SUBROUTINE POBERR C$$$ SUBROUTINE PRNTOUT(SEQLP,ICALL) - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -10559,7 +10610,7 @@ SUBROUTINE PRNTOUT(SEQLP,ICALL) C$$$ SUBROUTINE PRSTNS(WIND) - PARAMETER (NST=999) + PARAMETER (NST=2499) COMMON /HEADER/ SID(NST), DHR(NST), XOB(NST), YOB(NST), & ELV(NST), SQN(NST), ITP(NST), NLV, & NEV, ISF(NST), NLVM, NLVW @@ -10727,7 +10778,7 @@ SUBROUTINE PRSTNS(WIND) C$$$ C----------------------------------------------------------------------- SUBROUTINE QCOI(LDIM,IDIM,L0,IV0,NOB1,NOB2,IDH,OINC,HRES,HSTD,WTS) - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -10757,7 +10808,8 @@ SUBROUTINE QCOI(LDIM,IDIM,L0,IV0,NOB1,NOB2,IDH,OINC,HRES,HSTD,WTS) DATA MAXDIM /4/ DATA MINDIM /2/ - DATA MAXOBS /1000/ +C DATA MAXOBS /1000/ + DATA MAXOBS /2500/ DATA NFT /1/ C----------------------------------------------------------------------- @@ -10982,7 +11034,7 @@ SUBROUTINE QCOI(LDIM,IDIM,L0,IV0,NOB1,NOB2,IDH,OINC,HRES,HSTD,WTS) C$$$ SUBROUTINE RBLOCKS(SKIP,WIND,ENDIN) - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -11292,7 +11344,7 @@ SUBROUTINE ROUND(VAL,P,IV) C C$$$ SUBROUTINE SEARCH(LDIM,IDIM,L0,IV0,NOB1,NOB2,IDH,OINC,OG) - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -11492,7 +11544,7 @@ SUBROUTINE SEARCH(LDIM,IDIM,L0,IV0,NOB1,NOB2,IDH,OINC,OG) C C$$$ SUBROUTINE SETTMP - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -11752,7 +11804,7 @@ SUBROUTINE SHELL(V,IV,MAX,IREV) C$$$ SUBROUTINE SIGERR(LM) - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -12090,7 +12142,7 @@ SUBROUTINE SORT(RA,INDX,N) C SORT RA ACCORDING TO THE ORDER SPECIFIED BY THE C INDICES IN INDX. C - PARAMETER (NST=999) + PARAMETER (NST=2499) DIMENSION RA(*), WKSP(NST) INTEGER INDX(*) @@ -12139,7 +12191,7 @@ SUBROUTINE SORT(RA,INDX,N) C$$$ SUBROUTINE STAT(ITIME) - PARAMETER (NST=999) + PARAMETER (NST=2499) C C CALCULATE STATISTICS: @@ -13069,7 +13121,7 @@ SUBROUTINE STNCNT C$$$ SUBROUTINE STYPE - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -13212,7 +13264,7 @@ SUBROUTINE STYPE C$$$ SUBROUTINE T120(L,LM) - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -13319,7 +13371,7 @@ SUBROUTINE T120(L,LM) C$$$ SUBROUTINE T121(L,LM) - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -13394,7 +13446,7 @@ SUBROUTINE T121(L,LM) C$$$ SUBROUTINE T130(L,LM) - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -13528,7 +13580,7 @@ SUBROUTINE T130(L,LM) C$$$ SUBROUTINE T140(L,LM) - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -13612,7 +13664,7 @@ SUBROUTINE T140(L,LM) C$$$ SUBROUTINE T220(L,LM) - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -13770,7 +13822,7 @@ SUBROUTINE T220(L,LM) C$$$ SUBROUTINE T240(L,LM) - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -14194,7 +14246,7 @@ SUBROUTINE T240(L,LM) C C$$$ SUBROUTINE TMPCHK - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -14326,7 +14378,7 @@ SUBROUTINE TMPCHK C$$$ SUBROUTINE VOI(ITIME) - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -14796,7 +14848,7 @@ SUBROUTINE VSOLVE (A,B,NDIM,BAD,NFT,NS,MAXDIM) C C$$$ SUBROUTINE VTPEVN(DOVTMP) - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -14936,7 +14988,7 @@ SUBROUTINE VTPEVN(DOVTMP) C$$$ SUBROUTINE WBLOCKS - PARAMETER (NST=999) + PARAMETER (NST=2499) COMMON /HEADER/ SID(NST), DHR(NST), XOB(NST), YOB(NST), & ELV(NST), SQN(NST), ITP(NST), NLV, @@ -15039,7 +15091,7 @@ SUBROUTINE WBLOCKS C$$$ SUBROUTINE WINDATZ(SAME) - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -15279,7 +15331,7 @@ SUBROUTINE WINDATZ(SAME) C C$$$ SUBROUTINE WTISO - PARAMETER (NST=999) + PARAMETER (NST=2499) COMMON /ISO/ IDISO(NST),NUM,ISISO LOGICAL ISISO WRITE(6,600) @@ -15413,7 +15465,7 @@ SUBROUTINE WTSTATS C$$$ SUBROUTINE XHORRES - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS @@ -15505,7 +15557,7 @@ SUBROUTINE XHORRES C$$$ SUBROUTINE ZDIF - PARAMETER (NST=999) + PARAMETER (NST=2499) REAL(8) BMISS diff --git a/sorc/prepobs_cqcbufr.fd/radcor.f b/sorc/prepobs_cqcbufr.fd/radcor.f index 2c88733..8dfc421 100644 --- a/sorc/prepobs_cqcbufr.fd/radcor.f +++ b/sorc/prepobs_cqcbufr.fd/radcor.f @@ -82,7 +82,7 @@ C C$$$ SUBROUTINE RADEVN - PARAMETER (NST=999) + PARAMETER (NST=2499) PARAMETER (NRID=800) ! max # of raob ids listed per inst. type REAL(8) BMISS @@ -166,7 +166,7 @@ SUBROUTINE RADEVN C INITIALIZE ALL UNCORRECTED HEIGHTS AND TEMPS AS MISSING C ------------------------------------------------------- - + PRINT *, "NNNEEE RADCOR INIT1" KMIN = LEVRAD KMAX = 16 DHT = 0 @@ -179,14 +179,14 @@ SUBROUTINE RADEVN IN = BMISS INM = 0 - + PRINT *, "NNNEEE RADCOR INIT2" ALON = MOD(720.+360.-XOB(IS),360.) JTYPE = ITP(IS) IF(JTYPE.LE.0 .OR. (JTYPE.GE.255.AND.JTYPE.NE.20000)) JTYPE = 255 IF(JTYPE.NE.20000) CALL TAB(JTYPE) ! (inst. type may be set to ! 20000 for special cases in ! cqcbufr.f) - + PRINT *, "NNNEEE RADCOR 3" IF(IRCTBL.EQ.1) THEN C COME HERE FOR IRCTBL=1 CORRECTIONS (OLDEST TABLES) @@ -194,7 +194,7 @@ SUBROUTINE RADEVN C NEW CHECKS FOR THE NEW RADIOSONDE TYPES C --------------------------------------- - + PRINT *, "NNNEEE RC TYPES" IF(JTYPE.EQ.14) JTYPE = 4 ! VAISALA (IN/OUT OF FINLAND) IF(JTYPE.EQ.20) JTYPE = 12 ! RUSSIAN RKZ @@ -207,25 +207,29 @@ SUBROUTINE RADEVN C ---------------------------------------------------- IF(SID(IS)(1:1).EQ.'5') JTYPE = 19 - + PRINT *, "NNNEEE RC TYPES END" ENDIF BAL_DRIFT = .TRUE. C FILL THE MANDATORY LEVEL EVENT AND CORRECTION ARRAYS FOR THIS REPORT C -------------------------------------------------------------------- - + PRINT *, "NNNEEE RC MANDATORY LEVELS" DO L=1,NLV + PRINT *, "NNNEEE RC L NLV =,", L, NLV M = MANLEV(POB(L)) + PRINT *, "NNN RC MANLEV M= ", M IF(M.GT.0 .AND. M.LE.KMAX) THEN + PRINT *, "NNNEEE RC M>=0, M Date: Fri, 28 Apr 2023 17:28:40 +0000 Subject: [PATCH 2/2] remove print statements --- sorc/prepobs_cqcbufr.fd/cqcbufr.f | 52 ------------------------------- sorc/prepobs_cqcbufr.fd/radcor.f | 12 ------- 2 files changed, 64 deletions(-) diff --git a/sorc/prepobs_cqcbufr.fd/cqcbufr.f b/sorc/prepobs_cqcbufr.fd/cqcbufr.f index 1e7b710..aa96f5e 100644 --- a/sorc/prepobs_cqcbufr.fd/cqcbufr.f +++ b/sorc/prepobs_cqcbufr.fd/cqcbufr.f @@ -334,7 +334,6 @@ PROGRAM PREPOBS_CQCBUFR & WRT23 CALL W3TAGB('PREPOBS_CQCBUFR',2020,0009,0067,'NP22') - print *, "NNNEEE W3TAGB done" TEST = .TRUE. ! Set .T. for tests to give more print !!! #### BE CAREFUL ##### in subr. POBERR, @@ -359,15 +358,11 @@ PROGRAM PREPOBS_CQCBUFR C REAL*8 (or REAL*4) variable that is missing is NINT'd C ------------------------------------------------------------------- CALL ISETPRM ( 'MXMSGL', 600000 ) ! CH 08/31/21 - print *, "NNNEEE ISETPRM done" CALL ISETPRM ( 'MAXSS', 600000 ) ! CH 08/31/21 - print *, "NNNEEE ISETPRM2 done" ccccc CALL SETBMISS(10E10_8) CALL SETBMISS(10E8_8) - print *, "NNNEEE SETBMISS done" BMISS=GETBMISS() CALL MAXOUT(50000) ! CH 08/31/21 - print *, "NNNEEE MAXOUT(50000) done" XMISS=BMISS IMISS=10E8 print * @@ -375,7 +370,6 @@ PROGRAM PREPOBS_CQCBUFR print * CALL ACCUM - print *, "NNNEEE ACCUM done" START = .TRUE. ! Input opens data file when START=.T. ENDIN = .FALSE. ! Initialize SKIP = .FALSE. ! Initialize @@ -389,7 +383,6 @@ PROGRAM PREPOBS_CQCBUFR IF(SINGLE) THEN CALL SETTMP - print *, "NNNEEE SETTMP done" GOTO 300 ENDIF @@ -397,43 +390,30 @@ PROGRAM PREPOBS_CQCBUFR C --------------------------------------------- 100 CONTINUE - print *, "NNNEEE 100 BEGINS" ITIME = 1 WRITE(60,520) START,ENDIN,SKIP,SAME,WIND,ITIME,USESQN 520 FORMAT(' MAIN--START,ENDIN,SKIP,SAME,WIND,ITIME,USESQN: ', & 5(L2,2X),I5,2X,L2) CALL INPUT(START,ENDIN,SKIP,SAME,WIND,ITIME,USESQN) - print *, "NNNEEE INPUT DONE" ! Read data for 1 station IF(ENDIN) GOTO 200 IF(SKIP .OR. WIND) GOTO 100 CALL RESIDS(ITIME) ! Calculate all but horizontal resids - print *, "NNNEEE RESIDS DONE" CALL ISGOOD ! Preliminary quality assessment - print *, "NNNEEE ISGOOD DONE" GOTO 100 200 CONTINUE - print *, "NNNEEE 200 BEGINS" IF(DOTMP) THEN - print *, "NNNEEE DOTMP BEGINS" CALL INPUT2 ! Read data for temporal check - print *, "NNNEEE DOTMP INPUT2 done" CALL TMPCHK ! Perform temporal check - print *, "NNNEEE DOTMP TMPCHK done" ELSE - print *, "NNNEEE NOTDOTMP BEGINS" CALL SETTMP - print *, "NNNEEE SETTMP done" ENDIF CALL HORRES ! Calculate horizontal residuals - print *, "NNNEEE HORRES done" CALL STAT(ITIME) ! Calculate & print statistics - print *, "NNNEEE STAT done" CALL XHORRES ! Calc normalized horizontal residuals - print *, "NNNEEE XHORRES done" START = .TRUE. @@ -441,7 +421,6 @@ PROGRAM PREPOBS_CQCBUFR C ---------------------------------------- 300 CONTINUE - print *, "NNNEEE 300 BEGINS" ITIME = 2 ISC = 0 LAST = 0 @@ -450,91 +429,61 @@ PROGRAM PREPOBS_CQCBUFR IF(.NOT.SINGLE) THEN CALL INPUT(START,ENDIN,SKIP,SAME,WIND,ITIME,USESQN) ! Read data a 2nd time, 1 rpt at a time - print *, "NNNEEE NOT SINGLE INPUT done" ELSE CALL RBLOCKS(SKIP,WIND,ENDIN) - print *, "NNNEEE RBLOCKS done" ENDIF IF(ENDIN) GOTO 600 IF(SKIP) GOTO 500 IF(WIND) THEN - print *, "NNNEEE WIND BEGINS" CALL INCRW - print *, "NNNEEE WIND INCRW done" CALL PRSTNS(WIND) - print *, "NNNEEE WIND PRSTNS done" GOTO 500 ENDIF CALL CKPS - print *, "NNNEEE CKPS done" CALL RESIDS(ITIME) - print *, "NNNEEE RESIDS done" CALL PRSTNS(WIND) - print *, "NNNEEE ANOTHER PRSTNS done" ICALL = 3 CALL PRNTOUT(SEQQ,ICALL) - print *, "NNNEEE PRNTOUT done" C LOOP THROUGH LEVELS UNTIL TOP IS REACHED C ---------------------------------------- 400 CONTINUE ISC = ISC + 1 - print *, "NNNEEE 400 begins" CALL DMA(ANY,OBS) ! Decision Making Algorithm - print *, "NNNEEE DMS DONE" CALL CHANGE(ANY,SINGLE,SEQQ) ! Apply corrs to the data - print *, "NNNEEE CHANGE DONE" IF(ANY) ANYS = .TRUE. CALL RESIDS(ITIME) - print *, "NNNEEE ANOTHER RESIDS done" IF(ANY) CALL DHOR ! Calculate changes to hor resids IF((ANY .OR. .NOT.OBS .OR. LAST.LT.NLEV) .AND. ISC.LT.30) GOTO 400 CALL STEVNTS ! Print BUFR events for single stn - print *, "NNNEEE STEVNTS done" ICALL = 1 IF(ANYS .AND. OBS) CALL PRNTOUT(SEQQ,ICALL) CALL MASEVN ! Write CQC mass events - print *, "NNNEEE MASEVN done" 500 CONTINUE CALL AUXLEVS(SKIP,SAME,WIND,SINGLE,ANYS) - print *, "NNNEEE AUXLEVS done" IF(.NOT.WIND) THEN - print *, "NNNEEE NOT WIND AA begins" CALL RADEVN ! Write radiation correction events - print *, "NNNEEE NOT WIND RADEVN done" CALL VTPEVN(DOVTMP) ! Write virtual temperature events - print *, "NNNEEE NOT WIND VTPEVN(DOVTMP) done" ENDIF CALL OUTPUT(ENDIN,SINGLE) - print *, "NNNEEE OUTPUT AAAA ends" GOTO 300 ! Go back for the next report C END OF DATA REACHED C ------------------- 600 CONTINUE - print *, "NNNEEE 600 BEGINS" CALL STAT(ITIME) - print *, "NNNEEE STAT done" CALL PEVENTS ! Print events - print *, "NNNEEE PEVENTS done" IF(.NOT.SINGLE) CALL STNCNT ! Print counts by WMO block - print *, "NNNEEE STNCNT done" I2 = IEVENT ICALL = 2 CALL EVPROC(1,I2,ICALL) ! Generate, print BUFR events - print *, "NNNEEE EVPROC done" CALL WTSTATS ! Write statistics for RADCOR - print *, "NNNEEE WTSTATS done" CALL WTISO - print *, "NNNEEE WTISO done" CALL CLOSBF(NFIN) - print *, "NNNEEE CLOSBF done" CALL CLOSBF(NFOUT) - print *, "NNNEEE CLOSBF2 done" CALL W3TAGE('PREPOBS_CQCBUFR') - print *, "NNNEEE W3TAGE2 done" STOP END C********************************************************************** @@ -7464,7 +7413,6 @@ SUBROUTINE INPUT(START,ENDIN,SKIP,SAME,WIND,ITIME,USESQN) ENDIF IF(IS+1.GT.NST) THEN - PRINT *, "NNNEEE IS= ", IS PRINT *, 'MAXOBS (NST) EXCEEDED IN INPUT - STOP 99' CALL W3TAGE('PREPOBS_CQCBUFR') CALL ERREXIT(99) diff --git a/sorc/prepobs_cqcbufr.fd/radcor.f b/sorc/prepobs_cqcbufr.fd/radcor.f index 8dfc421..864fe1a 100644 --- a/sorc/prepobs_cqcbufr.fd/radcor.f +++ b/sorc/prepobs_cqcbufr.fd/radcor.f @@ -166,7 +166,6 @@ SUBROUTINE RADEVN C INITIALIZE ALL UNCORRECTED HEIGHTS AND TEMPS AS MISSING C ------------------------------------------------------- - PRINT *, "NNNEEE RADCOR INIT1" KMIN = LEVRAD KMAX = 16 DHT = 0 @@ -179,14 +178,12 @@ SUBROUTINE RADEVN IN = BMISS INM = 0 - PRINT *, "NNNEEE RADCOR INIT2" ALON = MOD(720.+360.-XOB(IS),360.) JTYPE = ITP(IS) IF(JTYPE.LE.0 .OR. (JTYPE.GE.255.AND.JTYPE.NE.20000)) JTYPE = 255 IF(JTYPE.NE.20000) CALL TAB(JTYPE) ! (inst. type may be set to ! 20000 for special cases in ! cqcbufr.f) - PRINT *, "NNNEEE RADCOR 3" IF(IRCTBL.EQ.1) THEN C COME HERE FOR IRCTBL=1 CORRECTIONS (OLDEST TABLES) @@ -194,7 +191,6 @@ SUBROUTINE RADEVN C NEW CHECKS FOR THE NEW RADIOSONDE TYPES C --------------------------------------- - PRINT *, "NNNEEE RC TYPES" IF(JTYPE.EQ.14) JTYPE = 4 ! VAISALA (IN/OUT OF FINLAND) IF(JTYPE.EQ.20) JTYPE = 12 ! RUSSIAN RKZ @@ -207,29 +203,22 @@ SUBROUTINE RADEVN C ---------------------------------------------------- IF(SID(IS)(1:1).EQ.'5') JTYPE = 19 - PRINT *, "NNNEEE RC TYPES END" ENDIF BAL_DRIFT = .TRUE. C FILL THE MANDATORY LEVEL EVENT AND CORRECTION ARRAYS FOR THIS REPORT C -------------------------------------------------------------------- - PRINT *, "NNNEEE RC MANDATORY LEVELS" DO L=1,NLV - PRINT *, "NNNEEE RC L NLV =,", L, NLV M = MANLEV(POB(L)) - PRINT *, "NNN RC MANLEV M= ", M IF(M.GT.0 .AND. M.LE.KMAX) THEN - PRINT *, "NNNEEE RC M>=0, M