subroutine write_obsdiags(cdfile) !#define VERBOSE !#define DEBUG_TRACE #include "mytrace.H" !$$$ subprogram documentation block ! ! abstract: Write obsdiags data structure to file. ! ! program history log: ! 2007-07-05 tremolet ! 2007-10-03 todling - expanded to account for full observer ! 2007-10-24 todling - add parameter nchnperobs to obsdiag ! 2009-01-08 todling - remove reference to ozohead ! 2009-01-27 todling - add gps write ! ! input argument list: ! cdfile - filename to write data ! !$$$ use mpeu_util, only: tell,die,perr,stdout_open,stdout_close use kinds, only: r_kind,i_kind use obsmod, only: nobs_type,obsdiags,obsptr,lobserver use obsmod, only: gpshead use obsmod, only: gpsptr use obsmod, only: i_ps_ob_type, i_t_ob_type, i_w_ob_type, i_q_ob_type, & i_spd_ob_type, i_srw_ob_type, i_rw_ob_type, i_dw_ob_type, & i_sst_ob_type, i_pw_ob_type, i_pcp_ob_type, i_oz_ob_type, & i_o3l_ob_type, i_gps_ob_type, i_rad_ob_type, i_lag_ob_type use gsi_4dvar, only: nobs_bins,l4dvar use mpimod, only: mype use jfunc, only: jiter, miter, last use timermod, only: timer_ini,timer_fnl implicit none character(len=*), parameter :: myname="write_obsdiags" character(len=*), intent(in) :: cdfile character(len=100) :: clfile character(len=5) :: clmype integer(i_kind) :: iunit,ii,jj,iobs,ierr integer(i_kind) :: icount(nobs_type,nobs_bins) logical :: muse logical :: all_sorted integer(i_kind) :: idv,iob,ich ! ---------------------------------------------------------- _ENTRY_(myname) call timer_ini(myname) !! call stdout_open('write_obsdiags/') iunit=77 clmype='.YYYY' write(clmype(2:5),'(I4.4)')mype clfile=trim(cdfile)//clmype if (mype==0) write(6,*)'Start writing obsdiags to file ',clfile open(iunit,file=trim(clfile),form='unformatted',action='write',iostat=ierr) if (ierr/=0) then write(6,*)'write_obsdiags: error open',ierr call stop2(316) end if icount = 0 do ii=1,nobs_bins do jj=1,nobs_type obsptr => obsdiags(jj,ii)%head iobs=0 idv=-huge(idv); iob=-huge(iob); ich=-huge(ich) all_sorted=.true. do while (associated(obsptr)) if(all_sorted) then ! checking of all_sorted is needed only when it is so far. all_sorted = & isinorder_((/ idv, iob, ich/), & (/obsptr%idv,obsptr%iob,obsptr%ich/) ) idv=obsptr%idv; iob=obsptr%iob; ich=obsptr%ich endif obsptr => obsptr%next iobs=iobs+1 enddo write(iunit)ii,jj,iobs,jiter #ifdef VERBOSE if(all_sorted) then call tell(myname,'obsdiags is sorted, (ob_type,ibin,mobs =',(/jj,ii,iobs/)) else call tell(myname,'obsdiags is NOT sorted, (ob_type,ibin,mobs =',(/jj,ii,iobs/)) endif call tell(myname,' ii =',ii) call tell(myname,' jj =',jj) call tell(myname,' iobs =',iobs) call tell(myname,'jiter =',jiter) _TRACE_(myname,'looping through obshead pointers') #endif obsptr => obsdiags(jj,ii)%head do while (associated(obsptr)) write(iunit) obsptr%idv,obsptr%iob,obsptr%ich write(iunit) obsptr%indxglb, obsptr%nchnperobs, obsptr%luse, obsptr%muse(1:jiter), & obsptr%nldepart(1:jiter), obsptr%tldepart(1:jiter), & obsptr%wgtjo, obsptr%obssen(1:jiter) obsptr => obsptr%next enddo !tmp if (l4dvar) then if(jj==i_ps_ob_type) call write_pshead_ () if(jj==i_t_ob_type) call write_thead_ () if(jj==i_w_ob_type) call write_whead_ () if(jj==i_q_ob_type) call write_qhead_ () if(jj==i_spd_ob_type) call write_spdhead_ () if(jj==i_srw_ob_type) call write_srwhead_ () if(jj==i_rw_ob_type) call write_rwhead_ () if(jj==i_dw_ob_type) call write_dwhead_ () if(jj==i_sst_ob_type) call write_ssthead_ () if(jj==i_pw_ob_type) call write_pwhead_ () if(jj==i_oz_ob_type) call write_ozhead_ () if(jj==i_o3l_ob_type) call write_o3lhead_ () if(jj==i_pcp_ob_type) call write_pcphead_ () if(jj==i_gps_ob_type) call write_gpshead_ () if(jj==i_rad_ob_type) call write_radhead_ () if(jj==i_lag_ob_type) call write_laghead_ () !tmp endif write(iunit)ii,jj enddo enddo close(iunit) if (mype==0) write(6,*)'Finish writing obsdiags to file ',clfile ! ---------------------------------------------------------- !! call stdout_close() call timer_fnl(myname) _EXIT_(myname) return contains function isinorder_(is,js) implicit none logical:: isinorder_ integer(i_kind),dimension(:),intent(in):: is,js integer(i_kind):: lsize,m,k character(len=*),parameter:: myname_=myname//'.isinorder_' lsize=size(is) if(size(is)/=size(js)) then call perr(myname_,'sizes of two arguments do not match') call perr(myname_,'size(is) =',size(is)) call perr(myname_,'size(js) =',size(js)) call die(myname_) endif m=0 k=0 do while(kjs(k)) m=+1 enddo isinorder_ = m<0 ! monotomic and unique end function isinorder_ subroutine write_pshead_ () !$$$ subprogram documentation block ! ! abstract: Write obs-specific data structure to file. ! ! program history log: ! 2007-10-03 todling ! 2008-12-08 todling - update to May08 version ! ! input argument list: ! !$$$ use obsmod, only: pshead, psptr use m_obdiag, only: ob_verify implicit none integer(i_kind) mobs logical:: all_sorted,passed integer(i_kind):: idv,iob character(len=*),parameter:: myname_=myname//'.write_pshead_' _ENTRY_(myname_) psptr => pshead(ii)%head mobs=0 idv=-huge(idv); iob=-huge(iob) all_sorted=.true. do while (associated(psptr)) if(all_sorted) then all_sorted = isinorder_((/idv,iob/),(/psptr%idv,psptr%iob/)) idv=psptr%idv; iob=psptr%iob endif psptr => psptr%llpoint mobs=mobs+1 enddo passed = ob_verify(pshead(ii),count=mobs,perr=.true.) if(.not.passed) then call die(myname_,'ob_verify(), (type,ibin,mobs) =',(/jj,ii,mobs/)) endif icount(jj,ii) = mobs write(iunit)mobs,jj #ifdef VERBOSE if(all_sorted) then call tell(myname_,'pshead is sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) else call tell(myname_,'pshead is NOT sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) endif #endif if(mobs==0) return psptr => pshead(ii)%head do while (associated(psptr)) write(iunit) psptr%idv, psptr%iob write(iunit) psptr%res, psptr%err2,psptr%raterr2,& psptr%time, psptr%b, psptr%pg, & psptr%luse, psptr%ppertb, psptr%kx, & psptr%wij, psptr%ij psptr => psptr%llpoint enddo ! if (mobs>0) write(6,*)'Wrote ps to obsdiag file, ii=', ii, ' mobs =', mobs _EXIT_(myname_) end subroutine write_pshead_ subroutine write_thead_ () !$$$ subprogram documentation block ! ! abstract: Write obs-specific data structure to file. ! ! program history log: ! 2007-10-03 todling ! 2008-12-08 todling - update to May08 version ! ! input argument list: ! !$$$ use obsmod, only: thead, tptr use m_obdiag, only: ob_verify implicit none integer(i_kind) mobs logical:: all_sorted,passed integer(i_kind):: idv,iob character(len=*),parameter:: myname_=myname//'.write_thead_' _ENTRY_(myname_) tptr => thead(ii)%head mobs=0 idv=-huge(idv); iob=-huge(iob) all_sorted=.true. do while (associated(tptr)) if(all_sorted) then all_sorted = isinorder_( (/idv,iob/),(/tptr%idv,tptr%iob/)) idv=tptr%idv; iob=tptr%iob endif tptr => tptr%llpoint mobs=mobs+1 enddo passed = ob_verify(thead(ii),count=mobs,perr=.true.) if(.not.passed) then call die(myname_,'ob_verify(), (type,ibin,mobs) =',(/jj,ii,mobs/)) endif write(iunit)mobs,jj icount(jj,ii) = mobs #ifdef VERBOSE if(all_sorted) then call tell(myname_,'thead is sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) else call tell(myname_,'thead is NOT sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) endif #endif if(mobs==0) return tptr => thead(ii)%head do while (associated(tptr)) write(iunit) tptr%idv,tptr%iob write(iunit) tptr%res, tptr%err2,tptr%raterr2,& tptr%time, tptr%b, tptr%pg, & tptr%use_sfc_model, tptr%tlm_tsfc, & tptr%luse, tptr%tpertb, tptr%tv_ob, & tptr%k1, tptr%kx, tptr%wij, tptr%ij tptr => tptr%llpoint enddo ! if (mobs>0) write(6,*)'Wrote t to obsdiag file, ii=', ii, ' mobs =', mobs _EXIT_(myname_) end subroutine write_thead_ subroutine write_whead_ () !$$$ subprogram documentation block ! ! abstract: Write obs-specific data structure to file. ! ! program history log: ! 2007-10-03 todling ! 2008-12-08 todling - update to May08 version ! ! input argument list: ! !$$$ use obsmod, only: whead, wptr use m_obdiag, only: ob_verify implicit none integer(i_kind) mobs logical:: all_sorted,passed integer(i_kind):: idv,iob character(len=*),parameter:: myname_=myname//'.write_whead_' _ENTRY_(myname_) wptr => whead(ii)%head mobs=0 idv=-huge(idv); iob=-huge(iob) all_sorted=.true. do while (associated(wptr)) if(all_sorted) then all_sorted = isinorder_((/idv,iob/),(/wptr%idv,wptr%iob/)) idv=wptr%idv; iob=wptr%iob endif wptr => wptr%llpoint mobs=mobs+1 enddo passed = ob_verify(whead(ii),count=mobs,perr=.true.) if(.not.passed) then call die(myname_,'ob_verify(), (type,ibin,mobs) =',(/jj,ii,mobs/)) endif write(iunit)mobs,jj icount(jj,ii) = mobs #ifdef VERBOSE if(all_sorted) then call tell(myname_,'whead is sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) else call tell(myname_,'whead is NOT sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) endif #endif if(mobs==0) return wptr => whead(ii)%head do while (associated(wptr)) write(iunit) wptr%idv , wptr%iob, wptr%diagu%ich, wptr%diagv%ich write(iunit) wptr%ures, wptr%vres, wptr%err2,wptr%raterr2,& wptr%time, wptr%b, wptr%pg, & wptr%luse, wptr%upertb, wptr%vpertb, & wptr%k1, wptr%kx, wptr%wij, wptr%ij wptr => wptr%llpoint enddo ! if (mobs>0) write(6,*)'Wrote w to obsdiag file, ii=', ii, ' mobs =', mobs _EXIT_(myname_) end subroutine write_whead_ subroutine write_qhead_ () !$$$ subprogram documentation block ! ! abstract: Write obs-specific data structure to file. ! ! program history log: ! 2007-10-03 todling ! 2008-12-08 todling - update to May08 version ! ! input argument list: ! !$$$ use obsmod, only: qhead, qptr use m_obdiag, only: ob_verify implicit none integer(i_kind) mobs logical:: all_sorted,passed integer(i_kind):: idv,iob character(len=*),parameter:: myname_=myname//'.write_qhead_' _ENTRY_(myname_) qptr => qhead(ii)%head mobs=0 idv=-huge(idv); iob=-huge(iob) all_sorted=.true. do while (associated(qptr)) if(all_sorted) then all_sorted = isinorder_((/idv,iob/),(/qptr%idv,qptr%iob/)) idv=qptr%idv; iob=qptr%iob endif qptr => qptr%llpoint mobs=mobs+1 enddo passed = ob_verify(qhead(ii),count=mobs,perr=.true.) if(.not.passed) then call die(myname_,'ob_verify(), (type,ibin,mobs) =',(/jj,ii,mobs/)) endif write(iunit)mobs,jj icount(jj,ii) = mobs #ifdef VERBOSE if(all_sorted) then call tell(myname_,'qhead is sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) else call tell(myname_,'qhead is NOT sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) endif #endif if(mobs==0) return qptr => qhead(ii)%head do while (associated(qptr)) write(iunit) qptr%idv, qptr%iob write(iunit) qptr%res, qptr%err2,qptr%raterr2,& qptr%time, qptr%b, qptr%pg, & qptr%luse, qptr%qpertb, & qptr%k1, qptr%kx, qptr%wij, qptr%ij qptr => qptr%llpoint enddo ! if (mobs>0) write(6,*)'Wrote q to obsdiag file, ii=', ii, ' mobs =', mobs _EXIT_(myname_) end subroutine write_qhead_ subroutine write_spdhead_ () !$$$ subprogram documentation block ! ! abstract: Write obs-specific data structure to file. ! ! program history log: ! 2007-10-03 todling ! ! input argument list: ! !$$$ use obsmod, only: spdhead, spdptr use m_obdiag, only: ob_verify implicit none integer(i_kind) mobs logical:: all_sorted,passed integer(i_kind):: idv,iob character(len=*),parameter:: myname_=myname//'.write_spdhead_' _ENTRY_(myname_) spdptr => spdhead(ii)%head mobs=0 idv=-huge(idv); iob=-huge(iob) all_sorted=.true. do while (associated(spdptr)) if(all_sorted) then all_sorted = isinorder_( (/idv,iob/), (/spdptr%idv,spdptr%iob/)) idv=spdptr%idv; iob=spdptr%iob endif spdptr => spdptr%llpoint mobs=mobs+1 enddo passed = ob_verify(spdhead(ii),count=mobs,perr=.true.) if(.not.passed) then call die(myname_,'ob_verify(), (type,ibin,mobs) =',(/jj,ii,mobs/)) endif write(iunit)mobs,jj icount(jj,ii) = mobs #ifdef VERBOSE if(all_sorted) then call tell(myname_,'spdhead is sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) else call tell(myname_,'spdhead is NOT sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) endif #endif if(mobs==0) return spdptr => spdhead(ii)%head do while (associated(spdptr)) write(iunit) spdptr%idv, spdptr%iob write(iunit) spdptr%res, spdptr%err2,spdptr%raterr2,& spdptr%time, spdptr%b, spdptr%pg, & spdptr%uges, spdptr%vges, & spdptr%luse, spdptr%wij, spdptr%ij spdptr => spdptr%llpoint enddo ! if (mobs>0) write(6,*)'Wrote spd to obsdiag file, ii=', ii, ' mobs =', mobs _EXIT_(myname_) end subroutine write_spdhead_ subroutine write_srwhead_ () !$$$ subprogram documentation block ! ! abstract: Write obs-specific data structure to file. ! ! program history log: ! 2007-10-03 todling ! ! input argument list: ! !$$$ use obsmod, only: srwhead, srwptr use m_obdiag, only: ob_verify implicit none integer(i_kind) mobs logical:: all_sorted,passed integer(i_kind):: idv,iob character(len=*),parameter:: myname_=myname//'.write_srwhead_' _ENTRY_(myname_) srwptr => srwhead(ii)%head mobs=0 idv=-huge(idv); iob=-huge(iob) all_sorted=.true. do while (associated(srwptr)) if(all_sorted) then all_sorted = isinorder_( (/idv,iob/),(/srwptr%idv,srwptr%iob/)) idv=srwptr%idv; iob=srwptr%iob endif srwptr => srwptr%llpoint mobs=mobs+1 enddo passed = ob_verify(srwhead(ii),count=mobs,perr=.true.) if(.not.passed) then call die(myname_,'ob_verify(), (type,ibin,mobs) =',(/jj,ii,mobs/)) endif write(iunit)mobs,jj icount(jj,ii) = mobs #ifdef VERBOSE if(all_sorted) then call tell(myname_,'srwhead is sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) else call tell(myname_,'srwhead is NOT sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) endif #endif if(mobs==0) return srwptr => srwhead(ii)%head do while (associated(srwptr)) write(iunit) srwptr%idv , srwptr%iob, srwptr%diagu%ich, srwptr%diagv%ich write(iunit) srwptr%res1, srwptr%res2,srwptr%err2,srwptr%raterr2,& srwptr%time, srwptr%b, srwptr%pg, & srwptr%ges1, srwptr%ges2, & srwptr%luse, srwptr%rsrw, srwptr%wij, srwptr%ij srwptr => srwptr%llpoint enddo _EXIT_(myname_) end subroutine write_srwhead_ subroutine write_rwhead_ () !$$$ subprogram documentation block ! ! abstract: Write obs-specific data structure to file. ! ! program history log: ! 2007-10-03 todling ! ! input argument list: ! !$$$ use obsmod, only: rwhead,rwptr use m_obdiag, only: ob_verify implicit none integer(i_kind) mobs logical:: all_sorted,passed integer(i_kind):: idv,iob character(len=*),parameter:: myname_=myname//'.write_rwhead_' _ENTRY_(myname_) rwptr => rwhead(ii)%head mobs=0 idv=-huge(idv); iob=-huge(iob) all_sorted=.true. do while (associated(rwptr)) if(all_sorted) then all_sorted = isinorder_( (/idv,iob/),(/rwptr%idv,rwptr%iob/)) idv=rwptr%idv; iob=rwptr%iob endif rwptr => rwptr%llpoint mobs=mobs+1 enddo passed = ob_verify(rwhead(ii),count=mobs,perr=.true.) if(.not.passed) then call die(myname_,'ob_verify(), (type,ibin,mobs) =',(/jj,ii,mobs/)) endif write(iunit)mobs,jj icount(jj,ii) = mobs #ifdef VERBOSE if(all_sorted) then call tell(myname_,'rwhead is sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) else call tell(myname_,'rwhead is NOT sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) endif #endif if(mobs==0) return rwptr => rwhead(ii)%head do while (associated(rwptr)) write(iunit) rwptr%idv, rwptr%iob write(iunit) rwptr%res, rwptr%err2,rwptr%raterr2,& rwptr%time, rwptr%b, rwptr%pg, & rwptr%cosazm, rwptr%sinazm, & rwptr%luse, rwptr%wij, rwptr%ij rwptr => rwptr%llpoint enddo _EXIT_(myname_) end subroutine write_rwhead_ subroutine write_dwhead_ () !$$$ subprogram documentation block ! ! abstract: Write obs-specific data structure to file. ! ! program history log: ! 2007-10-03 todling ! ! input argument list: ! !$$$ use obsmod, only: dwhead,dwptr use m_obdiag, only: ob_verify implicit none integer(i_kind) mobs logical:: all_sorted,passed integer(i_kind):: idv,iob character(len=*),parameter:: myname_=myname//'.write_dwhead_' dwptr => dwhead(ii)%head mobs=0 idv=-huge(idv); iob=-huge(iob) all_sorted=.true. do while (associated(dwptr)) if(all_sorted) then all_sorted = isinorder_ ((/idv,iob/), (/dwptr%idv,dwptr%iob/)) idv=dwptr%idv; iob=dwptr%iob endif dwptr => dwptr%llpoint mobs=mobs+1 enddo passed = ob_verify(dwhead(ii),count=mobs,perr=.true.) if(.not.passed) then call die(myname_,'ob_verify(), (type,ibin,mobs) =',(/jj,ii,mobs/)) endif write(iunit)mobs,jj icount(jj,ii) = mobs #ifdef VERBOSE if(all_sorted) then call tell(myname_,'dwhead is sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) else call tell(myname_,'dwhead is NOT sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) endif #endif if(mobs==0) return dwptr => dwhead(ii)%head do while (associated(dwptr)) write(iunit) dwptr%idv, dwptr%iob write(iunit) dwptr%res, dwptr%err2,dwptr%raterr2,& dwptr%time, dwptr%b, dwptr%pg, & dwptr%cosazm, dwptr%sinazm, & dwptr%luse, dwptr%wij, dwptr%ij dwptr => dwptr%llpoint enddo _EXIT_(myname_) end subroutine write_dwhead_ subroutine write_ssthead_ () !$$$ subprogram documentation block ! ! abstract: Write obs-specific data structure to file. ! ! program history log: ! 2007-10-03 todling ! ! input argument list: ! !$$$ use obsmod, only: ssthead, sstptr use m_obdiag, only: ob_verify implicit none integer(i_kind) mobs logical:: all_sorted,passed integer(i_kind):: idv,iob character(len=*),parameter:: myname_=myname//'.write_ssthead_' _ENTRY_(myname_) sstptr => ssthead(ii)%head mobs=0 idv=-huge(idv); iob=-huge(iob) all_sorted=.true. do while (associated(sstptr)) if(all_sorted) then all_sorted = isinorder_( (/idv,iob/), (/sstptr%idv,sstptr%iob/)) idv=sstptr%idv; iob=sstptr%iob endif sstptr => sstptr%llpoint mobs=mobs+1 enddo passed = ob_verify(ssthead(ii),count=mobs,perr=.true.) if(.not.passed) then call die(myname_,'ob_verify(), (type,ibin,mobs) =',(/jj,ii,mobs/)) endif write(iunit)mobs,jj icount(jj,ii) = mobs #ifdef VERBOSE if(all_sorted) then call tell(myname_,'ssthead is sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) else call tell(myname_,'ssthead is NOT sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) endif #endif if(mobs==0) return sstptr => ssthead(ii)%head do while (associated(sstptr)) write(iunit) sstptr%idv, sstptr%iob write(iunit) sstptr%res, sstptr%err2,sstptr%raterr2,& sstptr%time, sstptr%b, sstptr%pg, & sstptr%luse, sstptr%wij, sstptr%ij sstptr => sstptr%llpoint enddo _EXIT_(myname_) end subroutine write_ssthead_ subroutine write_pwhead_ () !$$$ subprogram documentation block ! ! abstract: Write obs-specific data structure to file. ! ! program history log: ! 2007-10-03 todling ! ! input argument list: ! !$$$ use gridmod, only: nsig use obsmod, only: pwhead, pwptr use m_obdiag, only: ob_verify implicit none integer(i_kind) mobs logical:: all_sorted,passed integer(i_kind):: idv,iob character(len=*),parameter:: myname_=myname//'.write_pwhead_' pwptr => pwhead(ii)%head mobs=0 idv=-huge(idv); iob=-huge(iob) all_sorted=.true. do while (associated(pwptr)) if(all_sorted) then all_sorted = isinorder_( (/idv,iob/), (/pwptr%idv,pwptr%iob/) ) idv=pwptr%idv; iob=pwptr%iob endif pwptr => pwptr%llpoint mobs=mobs+1 enddo passed = ob_verify(pwhead(ii),count=mobs,perr=.true.) if(.not.passed) then call die(myname_,'ob_verify(), (type,ibin,mobs) =',(/jj,ii,mobs/)) endif write(iunit)mobs,jj,nsig icount(jj,ii) = mobs #ifdef VERBOSE if(all_sorted) then call tell(myname_,'pwhead is sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) else call tell(myname_,'pwhead is NOT sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) endif #endif if(mobs==0) return pwptr => pwhead(ii)%head do while (associated(pwptr)) write(iunit) pwptr%idv, pwptr%iob write(iunit) pwptr%res, pwptr%err2,pwptr%raterr2,& pwptr%time, pwptr%b, pwptr%pg, & pwptr%luse, pwptr%wij, pwptr%ij, pwptr%dp pwptr => pwptr%llpoint enddo _EXIT_(myname_) end subroutine write_pwhead_ subroutine write_ozhead_ () !$$$ subprogram documentation block ! ! abstract: Write obs-specific data structure to file. ! ! program history log: ! 2007-10-03 todling ! 2008-11-25 todling - merged with NCEP-May-2008 ! ! input argument list: ! !$$$ use obsmod, only: ozhead, ozptr use m_obdiag, only: ob_verify implicit none integer(i_kind) mobs logical:: all_sorted,passed integer(i_kind):: idv,iob,k,nloz character(len=*),parameter:: myname_=myname//'.write_ozhead_' _ENTRY_(myname_) ozptr => ozhead(ii)%head mobs=0 idv=-huge(idv); iob=-huge(iob) all_sorted=.true. do while (associated(ozptr)) if(all_sorted) then all_sorted = isinorder_( (/idv,iob/), (/ozptr%idv,ozptr%iob/) ) idv=ozptr%idv; iob=ozptr%iob endif ozptr => ozptr%llpoint mobs=mobs+1 enddo passed = ob_verify(ozhead(ii),count=mobs,perr=.true.) if(.not.passed) then call die(myname_,'ob_verify(), (type,ibin,mobs) =',(/jj,ii,mobs/)) endif write(iunit)mobs,jj icount(jj,ii) = mobs #ifdef VERBOSE if(all_sorted) then call tell(myname_,'ozhead is sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) else call tell(myname_,'ozhead is NOT sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) endif #endif if(mobs==0) return ozptr => ozhead(ii)%head do while (associated(ozptr)) nloz = ozptr%nloz write(iunit) ozptr%nloz write(iunit) ozptr%idv,ozptr%iob if ( ozptr%nloz+1 /= size(ozptr%diags)) then call perr(myname_,'mismatching [%nloz,size(%diags)]') call perr(myname_,'%(idv,iob,nloz,size(%diags)) =', & (/ozptr%idv,ozptr%iob,ozptr%nloz,size(ozptr%diags)/)) call die(myname_) endif if ( any( (/(k,k=1,nloz+1)/) /= & (/(ozptr%diags(k)%ptr%ich,k=1,nloz+1)/) ) ) then call perr(myname_,'mismatching [%ich,%diags%ptr%ich]') call perr(myname_,'%(idv,iob,nloz,size(%diags)) =', & (/ozptr%idv,ozptr%iob,ozptr%nloz,size(ozptr%diags)/)) call perr(myname_,'%ich(:) =',(/(k,k=1,nloz+1)/)) call perr(myname_,'%diag(:)%ich =',(/(ozptr%diags(k)%ptr%ich,k=1,nloz+1)/)) call die(myname_) endif write(iunit) ozptr%res, ozptr%err2,ozptr%raterr2, ozptr%time, & ozptr%luse, ozptr%wij, ozptr%ij, ozptr%prs , ozptr%ipos ozptr => ozptr%llpoint enddo _EXIT_(myname_) end subroutine write_ozhead_ subroutine write_o3lhead_ () !$$$ subprogram documentation block ! ! abstract: Write obs-specific data structure to file. ! ! program history log: ! 2007-10-03 todling ! ! input argument list: ! !$$$ use obsmod, only: o3lhead, o3lptr use m_obdiag, only: ob_verify implicit none integer(i_kind) mobs logical:: all_sorted,passed integer(i_kind):: idv,iob character(len=*),parameter:: myname_=myname//'.write_o3lhead_' _ENTRY_(myname_) o3lptr => o3lhead(ii)%head mobs=0 idv=-huge(idv); iob=-huge(iob) all_sorted=.true. do while (associated(o3lptr)) if(all_sorted) then all_sorted = isinorder_( (/idv,iob/), (/o3lptr%idv,o3lptr%iob/) ) idv=o3lptr%idv; iob=o3lptr%iob endif o3lptr => o3lptr%llpoint mobs=mobs+1 enddo passed = ob_verify(o3lhead(ii),count=mobs,perr=.true.) if(.not.passed) then call die(myname_,'ob_verify(), (type,ibin,mobs) =',(/jj,ii,mobs/)) endif write(iunit)mobs,jj icount(jj,ii) = mobs #ifdef VERBOSE if(all_sorted) then call tell(myname_,'o3lhead is sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) else call tell(myname_,'o3lhead is NOT sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) endif #endif if(mobs==0) return o3lptr => o3lhead(ii)%head do while (associated(o3lptr)) write(iunit) o3lptr%idv, o3lptr%iob write(iunit) o3lptr%res, o3lptr%err2,o3lptr%raterr2,& o3lptr%time, o3lptr%b, o3lptr%pg, & o3lptr%luse, o3lptr%wij, o3lptr%ij o3lptr => o3lptr%llpoint enddo _EXIT_(myname_) end subroutine write_o3lhead_ subroutine write_gpshead_ () !$$$ subprogram documentation block ! ! abstract: Write obs-specific data structure to file. ! ! program history log: ! 2009-01-27 todling ! ! input argument list: ! !$$$ use obsmod, only: gpshead, gpsptr use gridmod, only : nsig use m_obdiag, only: ob_verify implicit none integer(i_kind) mobs logical:: all_sorted,passed integer(i_kind):: idv,iob character(len=*),parameter:: myname_=myname//'.write_gpshead_' _ENTRY_(myname_) gpsptr => gpshead(ii)%head mobs=0 idv=-huge(idv); iob=-huge(iob) all_sorted=.true. do while (associated(gpsptr)) if(all_sorted) then all_sorted = isinorder_( (/idv,iob/), (/gpsptr%idv,gpsptr%iob/) ) idv=gpsptr%idv; iob=gpsptr%iob endif gpsptr => gpsptr%llpoint mobs=mobs+1 enddo passed = ob_verify(gpshead(ii),count=mobs,perr=.true.) if(.not.passed) then call die(myname_,'ob_verify(), (type,ibin,mobs) =',(/jj,ii,mobs/)) endif write(iunit)mobs,jj,nsig icount(jj,ii) = mobs #ifdef VERBOSE if(all_sorted) then call tell(myname_,'gpshead is sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) else call tell(myname_,'gpshead is NOT sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) endif #endif if(mobs==0) return gpsptr => gpshead(ii)%head do while (associated(gpsptr)) write(iunit) gpsptr%idv,gpsptr%iob write(iunit) gpsptr%jac_t,gpsptr%jac_q,gpsptr%jac_p,& gpsptr%res,gpsptr%err2,& gpsptr%raterr2,gpsptr%time,& gpsptr%b,gpsptr%pg,& gpsptr%ij,gpsptr%wij,& gpsptr%luse gpsptr => gpsptr%llpoint enddo _EXIT_(myname_) end subroutine write_gpshead_ subroutine write_pcphead_ () !$$$ subprogram documentation block ! ! abstract: Write obs-specific data structure to file. ! ! program history log: ! 2007-10-03 todling ! ! input argument list: ! !$$$ use obsmod, only: pcphead, pcpptr use gridmod, only : nsig5 use pcpinfo, only : npredp use m_obdiag, only: ob_verify implicit none integer(i_kind) mobs logical:: all_sorted,passed integer(i_kind):: idv,iob character(len=*),parameter:: myname_=myname//'.write_pcphead_' _ENTRY_(myname_) pcpptr => pcphead(ii)%head mobs=0 idv=-huge(idv); iob=-huge(iob) all_sorted=.true. do while (associated(pcpptr)) if(all_sorted) then all_sorted = isinorder_( (/idv,iob/), (/pcpptr%idv,pcpptr%iob/) ) idv=pcpptr%idv; iob=pcpptr%iob endif pcpptr => pcpptr%llpoint mobs=mobs+1 enddo passed = ob_verify(pcphead(ii),count=mobs,perr=.true.) if(.not.passed) then call die(myname_,'ob_verify(), (type,ibin,mobs) =',(/jj,ii,mobs/)) endif write(iunit)mobs,jj,npredp,nsig5 icount(jj,ii) = mobs #ifdef VERBOSE if(all_sorted) then call tell(myname_,'pcphead is sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) else call tell(myname_,'pcphead is NOT sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) endif #endif if(mobs==0) return pcpptr => pcphead(ii)%head do while (associated(pcpptr)) write(iunit) pcpptr%idv, pcpptr%iob write(iunit) pcpptr%obs, pcpptr%err2,pcpptr%raterr2,& pcpptr%time, pcpptr%ges, pcpptr%icxp, & pcpptr%luse, pcpptr%wij, pcpptr%ij, & pcpptr%predp, pcpptr%dpcp_dvar pcpptr => pcpptr%llpoint enddo _EXIT_(myname_) end subroutine write_pcphead_ subroutine write_radhead_ () !$$$ subprogram documentation block ! ! abstract: Write obs-specific data structure to file. ! ! program history log: ! 2007-10-03 todling ! ! input argument list: ! !$$$ use obsmod, only: radhead, radptr use radinfo, only: npred use gridmod, only: nsig3p3 use m_obdiag, only: ob_verify implicit none integer(i_kind) mobs logical:: all_sorted,passed integer(i_kind):: idv,iob,k character(len=*),parameter:: myname_=myname//'.write_radhead_' integer(i_kind) i,j,nchan _ENTRY_(myname_) radptr => radhead(ii)%head mobs=0 idv=-huge(idv); iob=-huge(iob) all_sorted=.true. do while (associated(radptr)) if(all_sorted) then all_sorted = isinorder_( (/idv,iob/), (/radptr%idv,radptr%iob/) ) idv=radptr%idv; iob=radptr%iob endif radptr => radptr%llpoint mobs=mobs+1 enddo #ifdef VERBOSE call tell(myname_,' nbin =',nobs_bins) call tell(myname_,' ibin =',ii) call tell(myname_,' mobs =',mobs) call tell(myname_,' jj =',jj) call tell(myname_,' npred =',npred) call tell(myname_,'nsig3p3 =',nsig3p3) #endif passed = ob_verify(radhead(ii),count=mobs,perr=.true.) if(.not.passed) then call die(myname_,'ob_verify(), (type,ibin,mobs) =',(/jj,ii,mobs/)) endif write(iunit)mobs,jj,npred,nsig3p3 icount(jj,ii) = mobs #ifdef VERBOSE if(all_sorted) then call tell(myname_,'radhead is sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) else call tell(myname_,'radhead is NOT sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) endif #endif if(mobs==0) return radptr => radhead(ii)%head i=0 do while (associated(radptr)) i=i+1 nchan = radptr%nchan write(iunit) nchan write(iunit) radptr%idv,radptr%iob if(nchan/=size(radptr%diags)) then call perr(myname_,'mismatching [%nchan,size(%diags)]') call perr(myname_,'%(idv,iob,nchan,size(diags)) =', & (/radptr%idv,radptr%iob,radptr%nchan,size(radptr%diags)/)) call die(myname_) endif if( any( radptr%ich(:) /= & (/(radptr%diags(k)%ptr%ich,k=1,nchan)/) ) ) then call perr(myname_,'mismatching [%ich,%diags%%ptr%ich]') call perr(myname_,'%(idv,iob,nchan,size(diags)) =', & (/radptr%idv,radptr%iob,radptr%nchan,size(radptr%diags)/)) call perr(myname_,'%ich(:) =',radptr%ich(:)) call perr(myname_,'%diag(:)%ptr%ich =', & (/(radptr%diags(k)%ptr%ich,k=1,nchan)/)) call die(myname_) endif write(iunit) (radptr%diags(k)%ptr%ich,k=1,nchan) write(iunit) radptr%time, radptr%luse, radptr%wij, radptr%ij write(iunit) radptr%res write(iunit) radptr%err2 write(iunit) radptr%raterr2 write(iunit) radptr%pred write(iunit) radptr%icx write(iunit) radptr%dtb_dvar ! write(iunit) radptr%res, radptr%err2, radptr%raterr2,& ! radptr%time, radptr%pred1,radptr%pred2,& ! radptr%luse, radptr%wij, radptr%ij, & ! radptr%icx, radptr%dtb_dvar radptr => radptr%llpoint enddo ! if (mobs>0) write(6,*)'Wrote rad to obsdiag file, ii=', ii, ' mobs =', mobs _EXIT_(myname_) end subroutine write_radhead_ subroutine write_laghead_ () !$$$ subprogram documentation block ! ! abstract: Write obs-specific data structure to file (for lagrangian data). ! ! program history log: ! 2009-04-02 meunier ! ! input argument list: ! !$$$ use obsmod, only: laghead,lagptr use m_obdiag, only: ob_verify implicit none integer(i_kind)::mobs logical:: all_sorted,passed integer(i_kind):: idv,iob character(len=*),parameter:: myname_=myname//'.write_laghead_' _ENTRY_(myname_) lagptr => laghead(ii)%head mobs=0 idv=-huge(idv); iob=-huge(iob) all_sorted=.true. do while (associated(lagptr)) if(all_sorted) then all_sorted = isinorder_( (/idv,iob/), (/lagptr%idv,lagptr%iob/) ) idv=lagptr%idv; iob=lagptr%iob endif lagptr => lagptr%llpoint mobs=mobs+1 enddo passed = ob_verify(laghead(ii),count=mobs,perr=.true.) if(.not.passed) then call die(myname_,'ob_verify(), (type,ibin,mobs) =',(/jj,ii,mobs/)) endif write(iunit) mobs,jj icount(jj,ii) = mobs #ifdef VERBOSE if(all_sorted) then call tell(myname_,'laghead is sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) else call tell(myname_,'laghead is NOT sorted, (ob_type,ibin,mobs)=',(/jj,ii,mobs/)) endif #endif if(mobs==0) return lagptr => laghead(ii)%head do while (associated(lagptr)) write(iunit) lagptr%idv, lagptr%iob, lagptr%diag_lon%ich, lagptr%diag_lat%ich write(iunit) lagptr%res_lon, lagptr%res_lat, lagptr%err2_lon,& lagptr%err2_lat, lagptr%raterr2, lagptr%obslon, lagptr%obslat,& lagptr%geslon, lagptr%geslat, lagptr%intnum, lagptr%speci,& lagptr%specr, lagptr%time, lagptr%b, lagptr%pg, lagptr%luse lagptr => lagptr%llpoint enddo _EXIT_(myname_) end subroutine write_laghead_ end subroutine write_obsdiags