SUBROUTINE SET_OUTFLDS(kth,th,kpv,pv) ! !$$$ SUBPROGRAM DOCUMENTATION BLOCK ! . . . ! SUBPROGRAM: READCNTRLgrb2_xml READS POST xml CONTROL FILE ! PRGRMMR: J. WANG ORG: NCEP/EMC DATE: 12-01-27 ! ! ABSTRACT: ! THIS ROUTINE READS THE CONTROL FILE IN XML FORMAT SPECIFYING ! FIELD(S) TO POST, AND SAVE ALL THE FIELD INFORMATION IN ! A DATATYPE array PSET ! ! PROGRAM HISTORY LOG: ! 01_27_2012 Jun Wang - INITIAL CODE ! ! USAGE: CALL READCNTRL_XML(kth,kpv,pv,th) ! INPUT ARGUMENT LIST: ! KTH ! TH ! KPV ! PV ! ! OUTPUT ARGUMENT LIST: ! NONE - ! ! OUTPUT FILES: ! NONE ! ! SUBPROGRAMS CALLED: ! UTILITIES: ! ! LIBRARY: ! COMMON - RQSTFLDGRB2 ! CTLBLK ! ! ATTRIBUTES: ! LANGUAGE: FORTRAN ! MACHINE : IBM !$$$ ! ! ! INCLUDE ETA GRID DIMENSIONS. SET/DERIVE PARAMETERS. ! use xml_data_post_t,only: paramset,post_avblflds use grib2_module, only: num_pset,pset,nrecout,first_grbtbl,grib_info_init use lookup_mod, only: ITB,JTB,ITBQ,JTBQ use ctlblk_mod, only: npset, me, fld_info use rqstfld_mod, only: mxfld, iget, ritehd, lvlsxml, datset, ident, & iavblfld, nfld, lvls !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! ! DECLARE VARIABLES. ! integer, intent(in) :: KTH,KPV real, intent(in) :: th(kth),pv(kpv) ! integer L,IFLD,MFLD,IAVBL,IREC,I,J CHARACTER*50 AVBLGRB_NAME logical :: FOUND_FLD ! !****************************************************************************** ! START READCNTRL_XML HERE. ! ! IF(ME.EQ.0)THEN ! WRITE(6,*)'READCNTRL_XML: POSTING FCST HR ',IFHR,' FROM ', & ! IHRST,'UTC ',SDAT(1),'-',SDAT(2),'-',SDAT(3),' RUN' ! ENDIF ! ! INITIALIZE VARIABLES. ! ARRAY IGET IS THE "GET FIELD" FLAG ARRAY. ! DO IFLD=1,MXFLD !mp IGET(IFLD) = -1 IGET(IFLD) = 0 enddo ! ! SET FLAG TO OPEN NEW OUTPUT FILE ! LVLS = 0 RITEHD = .TRUE. !$omp parallel do private(i,j) DO J=1,size(LVLSXML,2) DO I=1,size(LVLSXML,1) LVLSXML(I,J) = 0 ENDDO ENDDO ! pset=paramset(npset) datset=pset%datset print *,'in readxml, num_pset=',num_pset,'datset=',trim(pset%datset),'npset=',npset ! ! NOW READ WHICH FIELDS ON ! WHICH LEVELS TO INTERPOLATE TO THE OUTPUT GRID. THE ! CHARACTER STRING "DONE" MARKS THE END OF THE OUTPUT ! FIELD SPECIFICATIONS. ! call grib_info_init() MFLD = size(pset%param) write(0,*)'start reading control file,MFLD=',MFLD,'datset=',datset,MXFLD if(size(post_avblflds%param)<=0) then write(0,*)'WRONG: post available fields not ready!!!' return endif ! IFLD=0 irec=0 DO I=1, MFLD ! SEE IF REQUESTED FIELD IS AVAILABLE. IF NOT, ! WRITE MESSAGE TO 6 AND DECREMENT FIELD ! COUNTER BY ONE. THEN READ NEXT REQUESTED FIELD. ! ! GET POST AVAILBLE FIELD INDEX NUMBER FOR EACH OUTPUT FIELDS IN PSET ! FOUND_FLD=.false. write(0,*)'cntfile,i=',i,'fld shortname=',trim(pset%param(i)%shortname) ! write(0,*)'size(post_avblflds%param)=',size(post_avblflds%param) doavbl: DO 20 J = 1,size(post_avblflds%param) ! if (me == 5) write(0,*)' j=',j,' me=',me,' mfld=',mfld if(trim(pset%param(i)%shortname)==trim(post_avblflds%param(j)%shortname)) then ! IFLD=IFLD+1 IAVBL=post_avblflds%param(j)%post_avblfldidx IGET(IAVBL)=IFLD IDENT(IFLD)=IAVBL IAVBLFLD(IFLD)=I FOUND_FLD=.true. call fill_psetfld(pset%param(i),post_avblflds%param(j)) call set_lvlsxml(pset%param(i),ifld,irec,kpv,pv,kth,th) exit doavbl ! endif 20 ENDDO doavbl ! IF(ME.EQ.0.and..not.FOUND_FLD)THEN WRITE(0,*)'FIELD ',trim(pset%param(i)%pname)//trim( & & pset%param(i)%fixed_sfc1_type),' NOT AVAILABLE' ENDIF if(me==0) & write(0,*)'in readxml,i=',i,'ifld=',ifld,'irec=',irec, & trim(pset%param(i)%pname),trim(pset%param(i)%fixed_sfc1_type), & 'lvl=',size(pset%param(i)%level),'lvlsxml(1,ifld)=',LVLSXML(1,IFLD), & 'ident(ifld)=',ident(ifld),'iget(ident(ifld))=',iget(ident(ifld)) ENDDO ! ! ALL DONE FOUNDING REQUESTED FIELDS FOR current OUTPUT GRID. ! SET NFLD TO TOTAL NUMBER OF REQUESTED OUTPUT FIELDS THAT ! ARE AVAILABLE., SET NRECOUT to total number of OUTPUT records ! NOTE: here NFLD i s total number of fields found in post_avblfld_table, ! while nrecoutis the total number of grib messages that go ! into the output file. One fieldmay contain many different levels, ! which each different level will be counted as one record ! NFLD = IFLD NRECOUT = IREC allocate(fld_info(NRECOUT+100)) do i=1,nrecout+100 fld_info(i)%ifld=0 fld_info(i)%lvl=0 fld_info(i)%lvl1=0 fld_info(i)%lvl2=0 fld_info(i)%ntrange=0 fld_info(i)%tinvstat=0 enddo write(0,*)'in readxml. nfld=',nfld,'nrecout=',nrecout ! ! skip creating ipv files if kth=0 and no isobaric fields are requested in ctl file if(kth==0 .and. iget(013)<=0)go to 999 ! ! ECHO OUTPUT FIELDS/LEVELS TO 6. ! ! IF(ME.EQ.0)THEN ! WRITE(6,*)'BELOW ARE FIELD/LEVEL/SMOOTHING ', & ! 'SPECIFICATIONS.,NFLD=',NFLD,'MXLVL=',MXLVL,'nrecout=',nrecout ! ENDIF ! DO 50 IFLD = 1,NFLD ! IF(ME.EQ.0)THEN ! i=IAVBLFLD(IFLD) ! write(0,*)'readxml,ifld=',ifld,'iget(',IDENT(ifld),')=',iget(ident(ifld)),'iavbl=',IAVBLFLD(iget(ident(ifld))),'postvar=',trim(pset%param(i)%pname), & ! trim(pset%param(i)%fixed_sfc1_type),'lvls=',LVLS(:,ifld) ! if(size(pset%param(i)%level)>0) then ! WRITE(0,*) pset%param(i)%level ! endif ! ENDIF ! 50 CONTINUE ! ! END OF ROUTINE. ! 999 CONTINUE print *,'end of read_postcntrl_xml' RETURN END