Page 1 Source Listing BUFR_TRANIMGR 2012-11-20 14:03 tranimgr.f 1 !$$$ MAIN PROGRAM DOCUMENTATION BLOCK 2 ! 3 ! MAIN PROGRAM: BUFR_TRANIMGR 4 ! PRGMMR: MELCHIOR ORG: NP22 DATE: 2012-11-08 5 ! 6 ! ABSTRACT: READS IN NESDIS GOES IMAGE RADIANCE DATA IN WMO BUFR 7 ! FORMAT, REFORMATS AND PACKS INTO A BUFR FILE WHICH CAN BE DATABASED 8 ! BY TRANJB. THERE ARE CURRENTLY SIX CHANNELS. 9 ! 10 ! PROGRAM HISTORY LOG: 11 ! 2001-09-19 X. Su - Original author 12 ! 2002-06-12 X. Su - New format of GOES radiance 13 ! 2002-10-25 X. Su, J. Woollen - New format of GOES radiance 14 ! 2003-01-30 X. Su, J. Woollen - New BUFR format of GOES radiance 15 ! 2004-09-03 X. Su - New BUFR format with Gaussian source 16 ! 2006-02-02 D. Keyser - Replaced call to BUFRLIB routine IREADIBM 17 ! with call to BUFRLIB routine IREADMG (IREADIBM obsolete with 18 ! 1/31/2006 version of BUFRLIB) 19 ! 2008-02-19 G. Krasowski - Replaced TMBRST, which stores brightness 20 ! temperature to the nearest 0.1 Kelvin, with TMBR and SDTB, which 21 ! stores brightness temperature and standard deviation of brightness 22 ! temperature, respectively, to the nearest 0.01 Kelvin, in calls to 23 ! UFBREP. 24 ! 2012-11-08 S. Melchior - Changes to run on WCOSS (e.g., replaced W3LIB 25 ! with more specific W3NCO). 26 ! 27 ! USAGE: 28 ! INPUT FILES: 29 ! UNIT 05 - STANDARD INPUT. W3TRNARG PARSES ARGUMENTS FROM 30 ! - STANDARD INPUT. 31 ! UNIT 11 - WMO BUFR FILE. 32 ! UNIT 19 - FOREIGN BUFR TABLE FILE CONTAINING BUFR TABLES A, 33 ! - B, AND D (FOR UNIT 11). 34 ! UNIT 20 - NCEP BUFR TABLE FILE CONTAINING BUFR TABLES A, B, AND 35 ! D (FOR UNIT 51). 36 ! 37 ! OUTPUT FILES: 38 ! UNIT 06 - PRINTOUT 39 ! UNIT 51 - POINTS TO THE OUTPUT BUFR FILE. TRANJB WILL PLACE 40 ! THE BUFR MESSAGES INTO THE PROPER TANKS. 41 ! 42 ! SUBPROGRAMS CALLED: 43 ! LIBRARY: 44 ! W3NCO - W3TRNARG W3TAGB W3TAGE ERREXIT 45 ! BUFRLIB - OPENBF CLOSBF OPENMB UFBINT UFBREP WRITSB 46 ! - IREADMG IREADSB DATELEN 47 ! 48 ! EXIT STATES: 49 ! COND = 0 - SUCCESSFUL RUN 50 ! = 1 - UNABLE TO PARSE INPUT ARGUMENTS IN W3TRNARG 51 ! = 253 - NO REPORTS WRITTEN OUT 52 ! 53 ! ATTRIBUTES: 54 ! LANGUAGE: FORTRAN 95 55 ! MACHINE: NCEP WCOSS 56 ! 57 !$$$ Page 2 Source Listing BUFR_TRANIMGR 2012-11-20 14:03 tranimgr.f 58 59 program BUFR_TRANIMGR 60 61 real(8),dimension(8) :: timein 62 real(8),dimension(10) :: satinfo,a 63 real(8),dimension(6,12) :: radin 64 real(8),dimension(6) :: pccfin 65 real(8),dimension(13,6) :: radout 66 real(8),dimension(5,12) :: cldinf 67 real(8),dimension(18) :: qcinf 68 real(8),dimension(14) :: sidpinf 69 integer :: iyr 70 71 character(8) :: subset,tlflag,subfgn 72 character(80) :: appchr,subdir,tankid 73 74 data lunin /11/ 75 data lindx /19/ 76 data lundx /20/ 77 data lunot /51/ 78 79 data idate_PREV/-99/,ldate_PREV/-99/ 80 81 !------------------------------------------------------------------------------ 82 83 call w3tagb('BUFR_TRANIMGR',2012,0313,0082,'NP22') 84 85 PRINT *, ' ' 86 PRINT *, ' ==> Welcome to BUFR_TRANIMGR -- Version 11/08/2012' 87 PRINT *, ' ' 88 89 call w3trnarg(subdir,lsubdr,tankid,ltnkid,appchr,lapchr,tlflag,jdate,kdate,ierr) 90 if(ierr /= 0) then 91 write(6,& 92 '(''UNABLE TO PARSE ARGS TO TRANSLATION ROUTINE - RETURN CODE = '',I5)') IERR 93 call w3tage('BUFR_TRANIMGR') 94 call errexit(ierr) 95 end if 96 97 subset = 'NC'//subdir(lsubdr-2:lsubdr)//tankid(ltnkid-2:ltnkid) 98 !------------------------------------------------------------------------------ 99 100 ird=0 101 iwt=0 102 ktskpt=0 103 ktskpt_msg=0 104 ikeep=0 105 radout=10e10 106 107 call datelen(10) 108 109 ! Open the input and output BUFR files 110 ! ------------------------------------ 111 112 !!!print *,'start to read data' 113 114 call openbf(lunin,'IN',lindx) Page 3 Source Listing BUFR_TRANIMGR 2012-11-20 14:03 tranimgr.f 115 !!!!!call openbf(lunot,'OUT',lundx) 116 call openbf(lunot,'NODX',lundx) 117 118 ! Read through the message/subsets in the file 119 ! -------------------------------------------- 120 121 do while(ireadmg(lunin,subfgn,idate) == 0) 122 123 !!!print *, 'idate =', idate 124 !!!print *,' subfgn is ',subfgn 125 126 if(idate.ne.idate_PREV) THEN 127 print *, ' ' 128 print *, 'OPENING INPUT MESSAGE WITH NEW DATE ',IDATE,' (SUBSET ',& 129 SUBFGN,')' 130 print *, ' ' 131 endif 132 idate_PREV = idate 133 134 do while(ireadsb(lunin) == 0) 135 136 ! Read the internal date and check for the realism 137 ! ------------------------------------------------ 138 139 call ufbint(lunin,timein,8,1,iret,& 140 'YEAR MNTH DAYS HOUR MINU SECO CLATH CLONH') 141 142 iyr = nint(timein(1)) 143 mon = nint(timein(2)) 144 idy = nint(timein(3)) 145 ihr = nint(timein(4)) 146 min = nint(timein(5)) 147 isc = nint(timein(6)) 148 ird=ird+1 149 150 if( iyr <= 0 .or. mon <1 .or. mon >12 .or. idy <1 .or. idy >31 .or. & 151 ihr <0 .or. ihr >24 .or. min <0 .or. min >60 .or. isc <0 .or. & 152 isc >60) then 153 154 print 200, iyr,mon,idy,ihr,min,isc,subfgn 155 200 format(' BAD DATE:',i4,5i2.2,' SUBSET:',a8) 156 ktskpt=ktskpt+1 157 else 158 159 radin=-e10 160 call ufbint(lunin,satinfo,10,1,iret,& 161 'SAID GCLONG SCLF SSNX SSNY NPPR NPPC SAZA SOZA LSQL') 162 call ufbrep(lunin,cldinf,5,12,iret,'SCCF SCBW CLDMNT NCLDMNT CLTP') 163 !!! call ufbrep(lunin,qcinf,1,18,iret,'TMBRST') 164 ! Split up array qcinf in ufbrep to include TMBR and SDTB for greater precision. -GSK 165 call ufbrep(lunin,qcinf(1),1,6,iret,'TMBR') 166 call ufbrep(lunin,qcinf(13),1,6,iret,'SDTB') 167 call ufbrep(lunin,sidpinf,1,14,iret,'SIDP') 168 call ufbrep(lunin,radin,6,12,iret,'RDTP RDCM SCCF SCBW SPRD RDNE') 169 call ufbrep(lunin,pccfin,1,6,iret,'PCCF') 170 171 if(qcinf(1) >1.0e8 .and. qcinf(2) >1.0e8 .and. qcinf(3) >1.0e8 .and. & Page 4 Source Listing BUFR_TRANIMGR 2012-11-20 14:03 tranimgr.f 172 qcinf(4) >1.0e8 .and. qcinf(5) >1.0e8 .and. qcinf(6) >1.0e8) then 173 ktskpt=ktskpt+1 174 ktskpt_msg=ktskpt_msg+1 175 cycle 176 else 177 178 ! Put into output array 179 ! --------------------- 180 181 radout(1,1:6)=sidpinf(3:8) 182 radout(2:7,1:6)=radin(1:6,1:6) 183 radout(8,1:6)=qcinf(1:6) 184 radout(9:11,1:6)=cldinf(3:5,1:6) 185 radout(12,1:6)=qcinf(13:18) 186 radout(13,1:6)=pccfin(1:6) 187 188 ! Check the data 189 ! -------------- 190 ikeep=ikeep+1 191 192 if(ikeep ==20) then 193 !!!!! if(pccfin(3) <10e10) then 194 write(6,300) iyr,mon,idy,ihr,min,isc,timein(7),timein(8) 195 300 format('year, month, day, hour, min, sec, lat, lon'/6i6,2f10.2) 196 write(6,400) 197 400 format('satid, center, sat class, xsize, ysize, nppr, nppc, ',& 198 'sat. zenith, sol. zenith,land/ocean ') 199 write(6,401) satinfo 200 401 format(10e12.3) 201 write(6,500) 202 500 format('rad. type, rad. calc., freq., band width, spec. rad., rad., ') 203 do j=1,12 204 write(6,501) j,(radin(i,j),i=1,6) 205 501 format(' chn',i3,2x,10e12.3) 206 enddo 207 208 write(6,402) 209 402 format ('Cloud info follows') 210 do j=1,12 211 write(6,501) j, (cldinf(i,j),i=1,5) 212 enddo 213 write(6,*) ' quality information follows' 214 write(6,403) (qcinf(i),i=1,18) 215 403 format(6e12.3) 216 217 write(6,*) 'percentage confidence info follows' 218 write(6,403) (pccfin(i),i=1,6) 219 220 write(6,*) 'output radiance' 221 do j=1,6 222 write(6,404) (radout(i,j),i=1,13) 223 404 format(7e12.3) 224 enddo 225 endif 226 227 ! Check report date to see if a new output message should be opened (tranjb 228 ! takes care of this for uncompressed files, but it doesn't hurt to have Page 5 Source Listing BUFR_TRANIMGR 2012-11-20 14:03 tranimgr.f 229 ! redundancy built in here) 230 ! ------------------------------------------------------------------------- 231 232 ldate=iyr*1000000+mon*10000+idy*100+ihr 233 !!!!! print *,' ldate ',ldate 234 !!!!! print *,' subset is ',subset 235 236 if(ldate.ne.ldate_PREV) then 237 print *, ' ' 238 print *, 'OPENING OUTPUT MESSAGE WITH NEW DATE ',LDATE,& 239 ' (SUBSET ',SUBSET,')' 240 print *, ' ' 241 endif 242 ldate_PREV = ldate 243 call openmb(lunot,subset,ldate) 244 245 ! Write out subset 246 ! ---------------- 247 248 call ufbint(lunot,timein,8,1,iret,& 249 'YEAR MNTH DAYS HOUR MINU SECO CLAT CLON') 250 call ufbint(lunot,satinfo,10,1,iret,& 251 'SAID GCLONG SCLF SSNX SSNY NPPR NPPC SAZA SOZA LSQL') 252 call ufbrep(lunot,radout,13,6,iret,& 253 'SIDP RDTP RDCM SCCF SCBW SPRD RDNE TMBRST CLDMNT NCLDMNT CLTP SDTB PCCF') 254 call WRITSB(lunot) 255 256 iwt=iwt+1 257 end if 258 end if 259 enddo 260 enddo 261 262 call closbf(lunin) 263 call closbf(lunot) 264 265 if(ktskpt_msg.gt.0) then 266 print *, ' ' 267 print *, ktskpt_msg,& 268 ' REPORTS SKIPPED BECAUSE ALL 5 BRIGHTNESS TEMPERATURES WERE MISSING' 269 print *, ' ' 270 print *, ' ' 271 end if 272 273 print *, '*** PROCESSING ENDED NORMALLY ***' 274 print*,'*** READ :',IRD 275 print*,'*** WROT :',IWT 276 print*,'*** SKIP :',KTSKPT 277 print*,'*** PROCESSING ENDED NORMALLY ***' 278 279 if(iwt == 0) then 280 print *, 'NO REPORTS PROCESSED -- DISABLING ALL SUBSEQUENT PROCESSING.' 281 CALL W3TAGE('BUFR_TRANIMGR') 282 CALL ERREXIT(253) 283 end if 284 285 CALL W3TAGE('BUFR_TRANIMGR') Page 6 Source Listing BUFR_TRANIMGR 2012-11-20 14:03 tranimgr.f 286 287 stop 288 end ENTRY POINTS Name MAIN__ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 200 Label 155 154 300 Label 195 194 400 Label 197 196 401 Label 200 199 402 Label 209 208 403 Label 215 214,218 404 Label 223 222 500 Label 202 201 501 Label 205 204,211 A Local 62 R(8) 8 1 10 APPCHR Local 72 CHAR 80 scalar 89 BUFR_TRANIMGR Prog 59 CLDINF Local 66 R(8) 8 2 60 162,184,211 CLOSBF Subr 262 262,263 DATELEN Subr 107 107 E10 Local 159 R(8) 8 scalar 159 ERREXIT Subr 94 94,282 I Local 204 I(4) 4 scalar 204,211,214,218,222 IDATE Local 121 I(4) 4 scalar 121,126,128,132 IDATE_PREV Local 79 I(4) 4 scalar 79,126,132 IDY Local 144 I(4) 4 scalar 144,150,154,194,232 IERR Local 89 I(4) 4 scalar 89,90,92,94 IHR Local 145 I(4) 4 scalar 145,151,154,194,232 IKEEP Local 104 I(4) 4 scalar 104,190,192 IRD Local 100 I(4) 4 scalar 100,148,274 IREADMG Func 121 I(4) 4 scalar 121 IREADSB Func 134 I(4) 4 scalar 134 IRET Local 139 I(4) 4 scalar 139,160,162,165,166,167,168,169,24 8,250,252 ISC Local 147 I(4) 4 scalar 147,151,152,154,194 IWT Local 101 I(4) 4 scalar 101,256,275,279 IYR Local 69 I(4) 4 scalar 142,150,154,194,232 J Local 203 I(4) 4 scalar 203,204,210,211,221,222 JDATE Local 89 I(4) 4 scalar 89 KDATE Local 89 I(4) 4 scalar 89 KTSKPT Local 102 I(4) 4 scalar 102,156,173,276 KTSKPT_MSG Local 103 I(4) 4 scalar 103,174,265,267 LAPCHR Local 89 I(4) 4 scalar 89 LDATE Local 232 I(4) 4 scalar 232,236,238,242,243 LDATE_PREV Local 79 I(4) 4 scalar 79,236,242 LINDX Local 75 I(4) 4 scalar 75,114 Page 7 Source Listing BUFR_TRANIMGR 2012-11-20 14:03 Symbol Table tranimgr.f Name Object Declared Type Bytes Dimen Elements Attributes References LSUBDR Local 89 I(4) 4 scalar 89,97 LTNKID Local 89 I(4) 4 scalar 89,97 LUNDX Local 76 I(4) 4 scalar 76,116 LUNIN Local 74 I(4) 4 scalar 74,114,121,134,139,160,162,165,166 ,167,168,169,262 LUNOT Local 77 I(4) 4 scalar 77,116,243,248,250,252,254,263 MIN Local 146 I(4) 4 scalar 146,151,154,194 MON Local 143 I(4) 4 scalar 143,150,154,194,232 NINT Func 142 scalar 142,143,144,145,146,147 OPENBF Subr 114 114,116 OPENMB Subr 243 243 PCCFIN Local 64 R(8) 8 1 6 169,186,218 QCINF Local 67 R(8) 8 1 18 165,166,171,172,183,185,214 RADIN Local 63 R(8) 8 2 72 159,168,182,204 RADOUT Local 65 R(8) 8 2 78 105,181,182,183,184,185,186,222,25 2 SATINFO Local 62 R(8) 8 1 10 160,199,250 SIDPINF Local 68 R(8) 8 1 14 167,181 SUBDIR Local 72 CHAR 80 scalar 89,97 SUBFGN Local 71 CHAR 8 scalar 121,129,154 SUBSET Local 71 CHAR 8 scalar 97,239,243 TANKID Local 72 CHAR 80 scalar 89,97 TIMEIN Local 61 R(8) 8 1 8 139,142,143,144,145,146,147,194,24 8 TLFLAG Local 71 CHAR 8 scalar 89 UFBINT Subr 139 139,160,248,250 UFBREP Subr 162 162,165,166,167,168,169,252 W3TAGB Subr 83 83 W3TAGE Subr 93 93,281,285 W3TRNARG Subr 89 89 WRITSB Subr 254 254 Page 8 Source Listing BUFR_TRANIMGR 2012-11-20 14:03 Subprograms/Common Blocks tranimgr.f SUBPROGRAMS/COMMON BLOCKS Name Object Declared Type Bytes Dimen Elements Attributes References BUFR_TRANIMGR Prog 59 COMPILER OPTIONS BEING USED -align nocommons -align nodcommons -align noqcommons -align records -align nosequence -align norec1byte -align norec2byte -align norec4byte -align norec8byte -align norec16byte -altparam -assume accuracy_sensitive -assume nobscc -assume nobuffered_io -assume nobyterecl -assume nocc_omp -assume nocstring -assume nodummy_aliases -assume nofpe_summary -assume noieee_fpe_flags -assume nominus0 -assume noold_boz -assume old_unit_star -assume noold_ldout_format -assume noold_logical_ldio -assume old_maxminloc -assume old_xor -assume protect_constants -assume noprotect_parens -assume split_common -assume source_include -assume nostd_intent_in -assume nostd_mod_proc_name -assume norealloc_lhs -assume underscore -assume no2underscores no -auto -auto_scalar no -bintext -ccdefault default -check noargs -check noarg_temp_created -check nobounds -check noformat -check nooutput_conversion -check nooverflow -check nopointers -check power -check noshape -check nounderflow -check nouninitialized -coarray-num-procs 0 no -coarray-config-file -convert big_endian -cross_reference -D __INTEL_COMPILER=1210 -D __unix__ -D __unix -D __linux__ -D __linux -D __gnu_linux__ -D unix -D linux -D __ELF__ -D __x86_64 -D __x86_64__ -D _MT -D __INTEL_COMPILER_BUILD_DATE=20120612 -D __i686 -D __i686__ -D __pentiumpro -D __pentiumpro__ -D __pentium4 -D __pentium4__ -D __tune_pentium4__ -D __SSE2__ -D __SSE__ -D __MMX__ -double_size 64 no -d_lines no -Qdyncom -error_limit 30 no -f66 no -f77rtl no -fast -fpscomp nofilesfromcmd -fpscomp nogeneral -fpscomp noioformat -fpscomp noldio_spacing -fpscomp nologicals no -fpconstant -fpe3 -fprm nearest no -ftz Page 9 Source Listing BUFR_TRANIMGR 2012-11-20 14:03 tranimgr.f -fp_model noprecise -fp_model fast -fp_model nostrict -fp_model nosource -fp_model nodouble -fp_model noextended -fp_model novery_fast -fp_model noexcept -fp_model nono_except -heap_arrays 0 no -threadprivate_compat -free -g0 -iface nomixed_str_len_arg -iface nono_mixed_str_len_arg no -intconstant -integer_size 32 no -mixed_str_len_arg no -module -names lowercase no -noinclude -O2 no -pad_source -real_size 64 no -recursive -reentrancy none no -sharable_localsaves -vec=simd -show noinclude -show map -show options no -syntax_only no -threadcom no -U no -vms -w noall -w nonone -w alignments -w noargument_checking -w nodeclarations -w general -w noignore_bounds -w noignore_loc -w nointerfaces -w notruncated_source -w uncalled -w uninitialized -w nounused -w usage -includepath : /gpfs/tp2/usrx/local/intel/composer_xe_2011_sp1.11.339/compiler/include/,.f,./.f,/usrx/local/intel/composerxe/mkl/include/.f, /usrx/local/intel/composerxe/tbb/include/.f,/gpfs/tp2/usrx/local/intel/composer_xe_2011_sp1.11.339/compiler/include/intel64/.f, /gpfs/tp2/usrx/local/intel/composer_xe_2011_sp1.11.339/compiler/include/.f,/usr/local/include/.f,/usr/lib/gcc/x86_64-redhat-linux/4.4.6/include/.f, /usr/include/.f,/usr/include/.f -list filename : tranimgr.lst -o filename : none COMPILER: Intel(R) Fortran 12.1-2100