module obsmod !$$$ module documentation block ! . . . . ! module: obsmod ! prgmmr: derber org: np23 date: 2003-09-25 ! ! abstract: This module contains variables and arrays pertinent for ! observational data. ! ! program history log: ! 2003-09-25 derber ! 2004-05-13 kleist, documentation ! 2004-06-15 treadon - update documentation ! 2004-07-23 derber - add conventional sst observations ! 2004-11-22 derber - remove weight, add logical for boundary point ! 2004-11-30 cucurull - add GPS RO data ! 2004-12-22 treadon - rename logical "idiag_conv" as "diag_conv", ! add write_diag logical, remove conv_diagsave ! from module ! 2005-01-28 cucurull - clean up code handling gps local refractivity ! 2005-03-01 parrish - nonlinear qc change to account for inflated obs error ! 2005-03-04 derber - modify for cleaned up surface emissivity sensitivity ! 2005-03-16 derber - add arrays to hold observation time ! 2005-05-27 derber - add logical oberrflg ! 2005-06-14 wu - add OMI oz (ozo) ! 2005-06-21 cucurull - add logical ref_obs (GPS), parameter grids_dim (GPS) ! - add GPS bending angle observations ! 2005-08-03 derber - move var qc parameters b_ and pg_ for conventional ! from qcmod to obsmod ! 2005-09-28 derber - consolidate weights and locations for observations ! 2005-11-22 wu - add variables and flag for perturbed conventional ! obs and a function routine to generate a random ! number with mean:0 variance:1 ! 2005-11-29 derber - move ozmz to guess_grids ! 2005-12-20 parrish - add variables to enable boundary layer forward model ! option for surface temperature observations ! 2005-12-21 treadon - add arrays and code for gps data ! 2006-02-03 derber - add new obs control and simplify makecobs call ! 2006-02-17 treadon - add stat check on all allocate and deallocate ! 2006-02-27 todling - introduce ndatmax ! 2006-03-21 treadon - modify optional perturbation to observations ! 2006-04-19 treadon - add logical switch dtbduv_on ! 2006-05-05 treadon - add maximum time window variable ! 2006-07-28 derber - modify to use new inner loop obs data structure ! 2006-09-20 cucurull - remove termt1in for GPS data, add gpstail%b_tkges ! for GPS data, remove b_psges ! 2006-10-25 sienkiewicz - add blacklst flag ! 2007-01-10 sienkiewicz - define level ozone obs types ! 2007-02-02 tremolet - trying things ! 2007-02-13 parrish - add logical switch offtime_data to allow use of obs files ! with ref time different from analysis time ! 2007-03-09 su - add observation perturbation paramters in the ! observation position structure ! 2007-03-19 tremolet - binning of observations ! 2007-04-17 todling - getting nhr_assimilation from gsi_4dvar ! 2007-05-03 todling - add reference to o3l ! 2007-05-30 h.liu - change wij to 2d array for oz_ob_type, ozo_ob_type ! 2007-05-31 tremolet - add observation diagnostics structure ! 2007-06-22 cucurull - modify gps_all_ob_type structure ! 2007-06-26 tremolet - observation sensitivity ! 2007-07-11 tremolet - increment sensitivity to obs ! 2007-07-26 cucurull - modify pressure structure in gps_ob_type ! 2007-10-24 todling - add nchnperobs to obsdiag ! 2007-11-12 todling - add interface to destroyobs ! 2008-03-24 wu - add variables and logical switch for adaptive oberror tuning ! 2008-11-19 todling - define offtime_data default differently when doing 4dvar ! 2009-01-08 todling - remove reference to ozohead/tail-structure ! 2009-01-09 gayno - add variable dsfcalc ! 2009-02-02 kleist - add variables for synthetic tc-mslp observations ! 2009-03-05 meunier - add lagrangean observation type ! 2009-07-09 park,purser,pondeca - add logical variable hilbert_curve for ! cross-validation in 2dvar ! 2010-02-10 jing - merge in obs key set (idv,iob,ich) in obs types for unique ! run-time identification (in sorting and searching). ! ! Subroutines Included: ! sub init_obsmod_dflts - initialize obs related variables to default values ! sub init_directories - create sub-directories for tasks specific i/o ! sub create_obsmod_vars - allocate obs related variables ! sub init_obsmod_vars - initialize obs related variables to actual values ! sub destroyobs - deallocate obs linked lists ! sub destroy_obsmod_vars - deallocate obsmod arrays ! sub destroy_genstats_gps- deallocate linked list for gsp statistics ! sub inquire_obsdiags ! ! Functions Included: ! fun ran01dom ! ! Variable Definitions: ! def oberror_tune - namelist logical to tune (=true) oberror ! def perturb_obs - namelist logical to perturb (=true) observations ! def perturb_fact - namelist scaling factor for observation perturbations ! def write_diag - namelist logical array to compute/write (=true) diag files ! def obs_setup - prefix for files passing pe relative obs data to setup routines ! def dsfcalc - specifies method to determine surface fields within a FOV ! def dfile - input observation file names ! def dsis - sensor/instrument/satellite flag from info files ! def dtype - observation types ! def ditype - observation group type (set in read_obs, e.g. rad,conv,etc) ! def time_window - half time window for obs type (hours) ! def time_window_max - maximum half time window (hours) ! def obsfile_all - file containing observations after initial read ! def ndat_types - number of available data types ! def ndat_times - number of available synoptic times ! def ndatmax - maximum number of data types ! def ndat - total number of data types ! def ipoint - pointer to input namelist for particular processor ! def iadate - analysis date and time array ! def ianldate - analysis date in YYYYMMDDHH variable ! def time_offset - analysis relative time offset ! def dplat - satellite (platform) id ! def dthin - satellite group ! def nsat1 - number of observations of satellites in each pe ! def mype_diaghdr - pe id for writing out satellite diagnostic file ! def dval - relative value of each profile within group ! def dmesh - mesh size (km) for radiance thinning grid (used in satthin) ! def pshead - surface pressure linked list head ! def pstail - surface pressure linked list tail ! def thead - temperature linked list head ! def ttail - temperature linked list tail ! def dwhead - doppler wind linked list head ! def dwtail - doppler wind linked list tail ! def rwhead - radial wind linked list head ! def rwtail - radial wind linked list tail ! def srwhead - superobed radial wind linked list head ! def srwtail - superobed radial wind linked list tail ! def whead - conventional wind linked list head ! def wtail - conventional wind linked list tail ! def qhead - moisture linked list head ! def qtail - moisture linked list tail ! def ssthead - sea surface temperature linked list head ! def ssttail - sea surface temperature linked list tail ! def pwhead - precipitable water linked list head ! def pwtail - precipitable water linked list tail ! def ozhead - sbuv ozone profile linked list head ! def oztail - sbuv ozone profile linked list tail ! def o3lhead - ozone level data linked list head ! def o3ltail - ozone level data linked list tail ! def radhead - radiance linked list head ! def radtail - radiance linked list tail ! def pcphead - precipitation linked list head ! def pcptail - precipitation linked list tail ! def laghead - lagrangian data linked list head ! def lagtail - lagrangian data linked list tail ! def lunobs_obs - unit to save satellite observation ! def iout_rad - output unit for satellite stats ! def iout_pcp - output unit for precipitation stats ! def iout_t - output unit for temperature stats ! def iout_q - output unit for moisture stats ! def iout_uv - output unit for wind stats ! def iout_oz - output unit for ozone stats ! def iout_ps - output unit for surface pressure stats ! def iout_pw - output unit for precipitable water stats ! def iout_rw - output unit for radar wind stats ! def iout_dw - output unit for doppler wind stats ! def iout_srw - output unit for radar superob wind stats ! def iout_gps - output unit for gps refractivity or bending angle stats ! def iout_sst - output unit for conventional sst stats ! def iout_lag - output unit for conventional lag stats ! def mype_t - task to handle temperature stats ! def mype_q - task to handle moisture stats ! def mype_uv - task to handle wind stats ! def mype_ps - task to handle surface pressure stats ! def mype_pw - task to handle precipitable water stats ! def mype_rw - task to handle radar wind stats ! def mype_dw - task to handle doppler wind stats ! def mype_srw - task to handle radar superob wind stats ! def mype_gps - task to handle gps observation stats ! def mype_sst - task to handle conventional sst stats ! def mype_lag - task to handle conventional lag stats ! def oberrflg - logical for reading in new observation error table ! .true. will read in obs errors from file 'errtable' ! .false. will not read in new obs errors ! def blacklst - logical for reading in station blacklist table ! .true. will read in blacklist from file 'blacklist' ! .false. will not read in blacklist ! def ref_obs - logical for reading type of local GPS observation ! .true. will read refractivity ! .false. will read bending angle ! def nprof_gps - total number of gps profiles over all tasks ! def sfcmodel - logical for switching on boundary model for surface data ! def dtbduv_on - logical for switching on (.true.) sensitivity of uv winds ! to microwave brightness temperatures ! def rmiss_single - missing value in diagnostic file ! def offtime_data - logical, if .true., then allow use of obs files with ref time ! different from analysis time. ! ! def hilbert_curve - logical, if .true., then generate hilbert curve based ! cross-validation datasets in 2dvar mode. ! def lread_obs_save - logical, if .true., then write out collective obs selection info ! def lread_obs_skip - logical, if .true., then read in collective obs selection info ! def obs_input_common - scratch file to receive collective obs selection info ! ! attributes: ! langauge: f90 ! machgine: ! !$$$ end documentation block use kinds, only: r_kind,i_kind,r_single use gsi_4dvar, only: l4dvar use constants, only: zero,one,two,three,four,five use mpimod, only: mpi_max,mpi_itype,mpi_comm_world,ierror,npe,mype implicit none ! set default as private private ! set subroutines and functions to public public :: init_obsmod_dflts public :: init_directories public :: create_obsmod_vars public :: init_obsmod_vars public :: destroyobs public :: destroy_obsmod_vars public :: ran01dom public :: destroy_genstats_gps public :: inquire_obsdiags ! set passed variables to public public :: iout_pcp,iout_rad,iadate,write_diag,oberrflg,ndat,dthin,dmesh,l_do_adjoint public :: lsaveobsens,lag_ob_type,o3l_ob_type,oz_ob_type,pcp_ob_type,dw_ob_type public :: sst_ob_type,srw_ob_type,spd_ob_type,rw_ob_type,gps_ob_type,gps_all_ob_type,tcp_ob_type public :: rad_ob_type,q_ob_type,pw_ob_type,ps_ob_type,w_ob_type,t_ob_type public :: obs_handle,yobs,i_ps_ob_type,i_t_ob_type,i_w_ob_type,i_q_ob_type public :: i_spd_ob_type,i_srw_ob_type,i_rw_ob_type,i_dw_ob_type,i_sst_ob_type public :: i_pw_ob_type,i_pcp_ob_type,i_oz_ob_type,i_o3l_ob_type,i_gps_ob_type public :: i_rad_ob_type,i_tcp_ob_type,i_lag_ob_type,obscounts,obsptr,nobs_type,obsdiags public :: cobstype,gpsptr,obs_diag,nprof_gps,gps_allhead,gps_allptr,time_offset,ianldate public :: iout_oz,dsis,ref_obs,obsfile_all,lobserver,perturb_obs,ditype,dsfcalc,dplat public :: time_window,dval,dtype,dfile,dirname,obs_setup,oberror_tune,offtime_data public :: lobsdiagsave,blacklst,hilbert_curve,lobskeep,time_window_max,sfcmodel public :: perturb_fact,dtbduv_on,ndatmax,nsat1,mype_diaghdr,wptr,whead,psptr,pshead public :: qptr,qhead,tptr,thead,lobsdiag_allocated,pstail,ttail,wtail,qtail,spdtail public :: spdhead,srwtail,srwhead,rwtail,rwhead,dwtail,dwhead,ssttail,ssthead,pwtail public :: pwhead,oztail,ozhead,o3ltail,o3lhead,pcptail,pcphead,gpstail,gpshead public :: radptr,radtail,radhead,lagtail,laghead,nloz_v8,nloz_v6,nobskeep,gps_alltail public :: grids_dim,rmiss_single,nchan_total,tcphead,tcptail,mype_sst,mype_gps public :: mype_uv,mype_dw,mype_rw,mype_srw,mype_q,mype_tcp,mype_lag,mype_ps,mype_t public :: mype_pw,iout_rw,iout_dw,iout_srw,iout_sst,iout_pw,iout_t,iout_q,iout_tcp public :: iout_lag,iout_uv,iout_gps,iout_ps,spdptr,srwptr,rwptr,dwptr,sstptr,pwptr public :: ozptr,o3lptr,pcpptr,lagptr,lread_obs_save,obs_input_common,lread_obs_skip public :: ndat_times ! public :: obs_diags,gps_all_ob_head,w_ob_head,ps_ob_head,q_ob_head public :: t_ob_head,spd_ob_head,rw_ob_head,dw_ob_head,sst_ob_head public :: pcp_ob_head,o3l_ob_head,gps_ob_head public :: lag_ob_head,srw_ob_head,pw_ob_head,oz_ob_head,rad_ob_head public :: tcp_ob_head,odiags ! Set parameters integer(i_kind),parameter:: ndatmax = 200 ! maximum number of observation files real(r_single), parameter:: rmiss_single = -999.0_r_single ! Declare types integer(i_kind),parameter:: i_ps_ob_type= 1 ! ps_ob_type integer(i_kind),parameter:: i_t_ob_type= 2 ! t_ob_type integer(i_kind),parameter:: i_w_ob_type= 3 ! w_ob_type integer(i_kind),parameter:: i_q_ob_type= 4 ! q_ob_type integer(i_kind),parameter:: i_spd_ob_type= 5 ! spd_ob_type integer(i_kind),parameter:: i_srw_ob_type= 6 ! srw_ob_type integer(i_kind),parameter:: i_rw_ob_type= 7 ! rw_ob_type integer(i_kind),parameter:: i_dw_ob_type= 8 ! dw_ob_type integer(i_kind),parameter:: i_sst_ob_type= 9 ! sst_ob_type integer(i_kind),parameter:: i_pw_ob_type=10 ! pw_ob_type integer(i_kind),parameter:: i_pcp_ob_type=11 ! pcp_ob_type integer(i_kind),parameter:: i_oz_ob_type=12 ! oz_ob_type integer(i_kind),parameter:: i_o3l_ob_type=13 ! o3l_ob_type integer(i_kind),parameter:: i_gps_ob_type=14 ! gps_ob_type integer(i_kind),parameter:: i_rad_ob_type=15 ! rad_ob_type integer(i_kind),parameter:: i_tcp_ob_type=16 ! tcp_ob_type integer(i_kind),parameter:: i_lag_ob_type=17 ! lag_ob_type integer(i_kind),parameter:: nobs_type = 17 ! number of observation types ! Structure for diagnostics type obs_diag sequence type(obs_diag), pointer :: next => NULL() real(r_kind), pointer :: nldepart(:) ! (miter+1) real(r_kind), pointer :: tldepart(:) ! (miter) real(r_kind), pointer :: obssen(:) ! (miter) real(r_kind) :: wgtjo integer(i_kind) :: indxglb integer(i_kind) :: nchnperobs ! number of channels per observations ! (dummy, expect for radiances) logical, pointer :: muse(:) ! (miter) logical :: luse integer(i_kind) :: idv,iob,ich ! device id and obs index for verification end type obs_diag type obs_diags integer(i_kind):: n_alloc=0 type(obs_diag), pointer :: head => NULL() type(obs_diag), pointer :: tail => NULL() end type obs_diags type odiags sequence type(obs_diag), pointer :: ptr => NULL() end type odiags ! Main observation data structure type ps_ob_type sequence type(ps_ob_type),pointer :: llpoint => NULL() type(obs_diag), pointer :: diags => NULL() real(r_kind) :: res ! surface pressure residual real(r_kind) :: err2 ! surface pressure error squared real(r_kind) :: raterr2 ! square of ratio of final obs error ! to original obs error real(r_kind) :: time ! observation time in sec real(r_kind) :: b ! variational quality control parameter real(r_kind) :: pg ! variational quality control parameter real(r_kind) :: wij(4) ! horizontal interpolation weights real(r_kind) :: ppertb ! random number adding to the obs integer(i_kind) :: ij(4) ! horizontal locations integer(i_kind) :: kx ! ob type logical :: luse ! flag indicating if ob is used in pen. integer(i_kind) :: idv,iob ! device id and obs index for sorting end type ps_ob_type type ps_ob_head integer(i_kind):: n_alloc=0 type(ps_ob_type),pointer :: head => NULL() end type ps_ob_head type tcp_ob_type sequence type(tcp_ob_type),pointer :: llpoint => NULL() type(obs_diag), pointer :: diags => NULL() real(r_kind) :: res ! surface pressure residual real(r_kind) :: err2 ! surface pressure error squared real(r_kind) :: raterr2 ! square of ratio of final obs error ! to original obs error real(r_kind) :: time ! observation time in sec real(r_kind) :: b ! variational quality control parameter real(r_kind) :: pg ! variational quality control parameter real(r_kind) :: wij(4) ! horizontal interpolation weights real(r_kind) :: ppertb ! random number adding to the obs integer(i_kind) :: ij(4) ! horizontal locations integer(i_kind) :: kx ! ob type logical :: luse ! flag indicating if ob is used in pen. integer(i_kind) :: idv,iob ! device id and obs index for sorting end type tcp_ob_type type tcp_ob_head integer(i_kind):: n_alloc=0 type(tcp_ob_type),pointer :: head => NULL() end type tcp_ob_head type t_ob_type sequence type(t_ob_type),pointer :: llpoint => NULL() type(obs_diag), pointer :: diags => NULL() real(r_kind) :: res ! temperature residual real(r_kind) :: err2 ! temperature error squared real(r_kind) :: raterr2 ! square of ratio of final obs error ! to original obs error real(r_kind) :: time ! observation time in sec real(r_kind) :: b ! variational quality control parameter real(r_kind) :: pg ! variational quality control parameter real(r_kind) :: tlm_tsfc(6) ! sensitivity vector for sfc temp ! forward model real(r_kind) :: wij(8) ! horizontal interpolation weights real(r_kind) :: tpertb ! random number adding to the obs logical :: luse ! flag indicating if ob is used in pen. logical :: use_sfc_model ! logical flag for using boundary model logical :: tv_ob ! logical flag for virtual temperature or integer(i_kind) :: k1 ! level of errtable 1-33 integer(i_kind) :: kx ! ob type integer(i_kind) :: ij(8) ! horizontal locations integer(i_kind) :: idv,iob ! device id and obs index for sorting end type t_ob_type type t_ob_head integer(i_kind):: n_alloc=0 type(t_ob_type),pointer :: head => NULL() end type t_ob_head type w_ob_type sequence type(w_ob_type),pointer :: llpoint => NULL() type(obs_diag), pointer :: diagu => NULL() type(obs_diag), pointer :: diagv => NULL() real(r_kind) :: ures ! u component residual real(r_kind) :: vres ! v component residual real(r_kind) :: err2 ! surface pressure error squared real(r_kind) :: raterr2 ! square of ratio of final obs error ! to original obs error real(r_kind) :: time ! observation time in sec real(r_kind) :: b ! variational quality control parameter real(r_kind) :: pg ! variational quality control parameter real(r_kind) :: wij(8) ! horizontal interpolation weights real(r_kind) :: upertb ! random number adding to the obs real(r_kind) :: vpertb ! random number adding to the obs integer(i_kind) :: ij(8) ! horizontal locations integer(i_kind) :: k1 ! level of errtable 1-33 integer(i_kind) :: kx ! ob type logical :: luse ! flag indicating if ob is used in pen. integer(i_kind) :: idv,iob ! device id and obs index for sorting end type w_ob_type type w_ob_head integer(i_kind):: n_alloc=0 type(w_ob_type),pointer :: head => NULL() end type w_ob_head type q_ob_type sequence type(q_ob_type),pointer :: llpoint => NULL() type(obs_diag), pointer :: diags => NULL() real(r_kind) :: res ! moisture residual real(r_kind) :: err2 ! moisture error squared real(r_kind) :: raterr2 ! square of ratio of final obs error ! to original obs error real(r_kind) :: time ! observation time in sec real(r_kind) :: b ! variational quality control parameter real(r_kind) :: pg ! variational quality control parameter real(r_kind) :: wij(8) ! horizontal interpolation weights real(r_kind) :: qpertb ! random number adding to the obs integer(i_kind) :: ij(8) ! horizontal locations integer(i_kind) :: k1 ! level of errtable 1-33 integer(i_kind) :: kx ! ob type logical :: luse ! flag indicating if ob is used in pen. integer(i_kind) :: idv,iob ! device id and obs index for sorting end type q_ob_type type q_ob_head integer(i_kind):: n_alloc=0 type(q_ob_type),pointer :: head => NULL() end type q_ob_head type spd_ob_type sequence type(spd_ob_type),pointer :: llpoint => NULL() type(obs_diag), pointer :: diags => NULL() real(r_kind) :: res ! speed observation real(r_kind) :: err2 ! speed error squared real(r_kind) :: raterr2 ! square of ratio of final obs error ! to original obs error real(r_kind) :: time ! observation time in sec real(r_kind) :: b ! variational quality control parameter real(r_kind) :: pg ! variational quality control parameter real(r_kind) :: wij(4) ! horizontal interpolation weights real(r_kind) :: uges ! guess u value real(r_kind) :: vges ! guess v value integer(i_kind) :: ij(4) ! horizontal locations logical :: luse ! flag indicating if ob is used in pen. integer(i_kind) :: idv,iob ! device id and obs index for sorting end type spd_ob_type type spd_ob_head integer(i_kind):: n_alloc=0 type(spd_ob_type),pointer :: head => NULL() end type spd_ob_head type srw_ob_type sequence type(srw_ob_type),pointer :: llpoint => NULL() type(obs_diag), pointer :: diagu => NULL() type(obs_diag), pointer :: diagv => NULL() real(r_kind) :: res1 ! first component residual real(r_kind) :: res2 ! second component residual real(r_kind) :: err2 ! surface pressure error squared real(r_kind) :: raterr2 ! square of ratio of final obs error ! to original obs error real(r_kind) :: time ! observation time in sec real(r_kind) :: b ! variational quality control parameter real(r_kind) :: pg ! variational quality control parameter real(r_kind) :: ges1 ! first component guess real(r_kind) :: ges2 ! second component guess real(r_kind) :: rsrw(4) ! forward model for radar superob wind real(r_kind) :: wij(8) ! horizontal interpolation weights integer(i_kind) :: ij(8) ! horizontal locations logical :: luse ! flag indicating if ob is used in pen. integer(i_kind) :: idv,iob ! device id and obs index for sorting end type srw_ob_type type srw_ob_head integer(i_kind):: n_alloc=0 type(srw_ob_type),pointer :: head => NULL() end type srw_ob_head type rw_ob_type sequence type(rw_ob_type),pointer :: llpoint => NULL() type(obs_diag), pointer :: diags => NULL() real(r_kind) :: res ! radial wind residual real(r_kind) :: err2 ! radial wind error squared real(r_kind) :: raterr2 ! square of ratio of final obs error ! to original obs error real(r_kind) :: time ! observation time in sec real(r_kind) :: b ! variational quality control parameter real(r_kind) :: pg ! variational quality control parameter real(r_kind) :: cosazm ! v factor real(r_kind) :: sinazm ! u factor real(r_kind) :: wij(8) ! horizontal interpolation weights integer(i_kind) :: ij(8) ! horizontal locations logical :: luse ! flag indicating if ob is used in pen. integer(i_kind) :: idv,iob ! device id and obs index for sorting end type rw_ob_type type rw_ob_head integer(i_kind):: n_alloc=0 type(rw_ob_type),pointer :: head => NULL() end type rw_ob_head type dw_ob_type sequence type(dw_ob_type),pointer :: llpoint => NULL() type(obs_diag), pointer :: diags => NULL() real(r_kind) :: res ! doppler wind residual real(r_kind) :: err2 ! radial wind error squared real(r_kind) :: raterr2 ! square of ratio of final obs error ! to original obs error real(r_kind) :: time ! observation time in sec real(r_kind) :: b ! variational quality control parameter real(r_kind) :: pg ! variational quality control parameter real(r_kind) :: cosazm ! v factor real(r_kind) :: sinazm ! u factor real(r_kind) :: wij(8) ! horizontal interpolation weights integer(i_kind) :: ij(8) ! horizontal locations logical :: luse ! flag indicating if ob is used in pen. integer(i_kind) :: idv,iob ! device id and obs index for sorting end type dw_ob_type type dw_ob_head integer(i_kind):: n_alloc=0 type(dw_ob_type),pointer :: head => NULL() end type dw_ob_head type sst_ob_type sequence type(sst_ob_type),pointer :: llpoint => NULL() type(obs_diag), pointer :: diags => NULL() real(r_kind) :: res ! sst residual real(r_kind) :: err2 ! sst error squared real(r_kind) :: raterr2 ! square of ratio of final obs error ! to original obs error real(r_kind) :: time ! observation time in sec real(r_kind) :: b ! variational quality control parameter real(r_kind) :: pg ! variational quality control parameter real(r_kind) :: wij(4) ! horizontal interpolation weights integer(i_kind) :: ij(4) ! horizontal locations logical :: luse ! flag indicating if ob is used in pen. integer(i_kind) :: idv,iob ! device id and obs index for sorting end type sst_ob_type type sst_ob_head integer(i_kind):: n_alloc=0 type(sst_ob_type),pointer :: head => NULL() end type sst_ob_head type pw_ob_type sequence type(pw_ob_type),pointer :: llpoint => NULL() type(obs_diag), pointer :: diags => NULL() real(r_kind) :: res ! precipitable water residual real(r_kind) :: err2 ! precipitable water error squared real(r_kind) :: raterr2 ! square of ratio of final obs error ! to original obs error real(r_kind) :: time ! observation time in sec real(r_kind) :: b ! variational quality control parameter real(r_kind) :: pg ! variational quality control parameter real(r_kind) :: wij(4) ! horizontal interpolation weights real(r_kind),dimension(:),pointer :: dp => NULL() ! delta pressure at mid layers at obs locations integer(i_kind) :: ij(4) ! horizontal locations logical :: luse ! flag indicating if ob is used in pen. integer(i_kind) :: idv,iob ! device id and obs index for sorting end type pw_ob_type type pw_ob_head integer(i_kind):: n_alloc=0 type(pw_ob_type),pointer :: head => NULL() end type pw_ob_head type oz_ob_type sequence type(oz_ob_type),pointer :: llpoint => NULL() type(odiags), dimension(:), pointer :: diags => NULL() real(r_kind),dimension(:),pointer :: res => NULL() ! ozone residual real(r_kind),dimension(:),pointer :: err2 => NULL() ! ozone error squared real(r_kind),dimension(:),pointer :: raterr2 => NULL() ! square of ratio of final obs error ! to original obs error real(r_kind) :: time ! observation time in sec real(r_kind),dimension(:,:),pointer :: wij => NULL() ! horizontal interpolation weights real(r_kind),dimension(:),pointer :: prs => NULL() ! pressure levels integer(i_kind),dimension(:),pointer :: ipos => NULL() integer(i_kind) :: nloz ! number of levels for this profile integer(i_kind) :: ij(4) ! horizontal locations logical :: luse ! flag indicating if ob is used in pen. integer(i_kind) :: idv,iob ! device id and obs index for sorting end type oz_ob_type type oz_ob_head integer(i_kind):: n_alloc=0 type(oz_ob_type),pointer :: head => NULL() end type oz_ob_head type o3l_ob_type sequence type(o3l_ob_type),pointer :: llpoint => NULL() type(obs_diag), pointer :: diags => NULL() real(r_kind) :: res ! ozone residual real(r_kind) :: err2 ! ozone obs error squared real(r_kind) :: raterr2 ! square of ratio of final obs error ! to original obs error real(r_kind) :: time ! observation time real(r_kind) :: b ! variational quality control parameter real(r_kind) :: pg ! variational quality control parameter real(r_kind) :: wij(8) ! horizontal interpolation weights integer(i_kind) :: ij(8) ! horizontal locations logical :: luse ! flag indicating if ob is used in pen. integer(i_kind) :: idv,iob ! device id and obs index for sorting end type o3l_ob_type type o3l_ob_head integer(i_kind):: n_alloc=0 type(o3l_ob_type),pointer :: head => NULL() end type o3l_ob_head type gps_ob_type sequence type(gps_ob_type),pointer :: llpoint => NULL() type(obs_diag), pointer :: diags => NULL() real(r_kind) :: res ! gps residual real(r_kind) :: err2 ! gps error squared real(r_kind) :: raterr2 ! square of ratio of final obs error ! to original obs error real(r_kind) :: time ! observation time in sec real(r_kind) :: b ! variational quality control parameter real(r_kind) :: pg ! variational quality control parameter real(r_kind) :: wij(4) ! horizontal interpolation weights real(r_kind),dimension(:),pointer :: jac_q => NULL() ! q jacobian real(r_kind),dimension(:),pointer :: jac_t => NULL() ! t jacobian real(r_kind),dimension(:),pointer :: jac_p => NULL() ! p jacobian integer(i_kind),dimension(:,:),pointer :: ij => NULL() logical :: luse ! flag indicating if ob is used in pen. integer(i_kind) :: idv,iob ! device id and obs index for sorting end type gps_ob_type type gps_ob_head integer(i_kind):: n_alloc=0 type(gps_ob_type),pointer :: head => NULL() end type gps_ob_head type gps_all_ob_type sequence type(gps_all_ob_type),pointer :: llpoint => NULL() type(gps_ob_type),pointer :: mmpoint => NULL() real(r_kind) :: ratio_err real(r_kind) :: obserr real(r_kind) :: dataerr real(r_kind) :: pg real(r_kind) :: b real(r_kind) :: loc real(r_kind) :: type real(r_kind),dimension(:),pointer :: rdiag => NULL() integer(i_kind) :: kprof logical :: luse ! flag indicating if ob is used in pen. logical :: muse ! flag indicating if ob is used in pen. character(8) :: cdiag integer(i_kind) :: idv,iob ! device id and obs index for sorting end type gps_all_ob_type type gps_all_ob_head integer(i_kind):: n_alloc=0 type(gps_all_ob_type),pointer :: head => NULL() end type gps_all_ob_head type rad_ob_type sequence type(rad_ob_type),pointer :: llpoint => NULL() type(odiags), dimension(:), pointer :: diags => NULL() real(r_kind),dimension(:),pointer :: res => NULL() ! error variances squared (nchan) real(r_kind),dimension(:),pointer :: err2 => NULL() ! error variances squared (nchan) real(r_kind),dimension(:),pointer :: raterr2 => NULL() ! ratio of error variances squared (nchan) real(r_kind) :: time ! observation time in sec real(r_kind) :: wij(4) ! horizontal interpolation weights real(r_kind),dimension(:,:),pointer :: pred => NULL() ! predictors (npred,nchan) real(r_kind),dimension(:,:),pointer :: dtb_dvar => NULL() ! error variances squared (nsig3p3,nchan) integer(i_kind),dimension(:),pointer :: icx => NULL() integer(i_kind) :: nchan ! number of channels for this profile integer(i_kind) :: ij(4) ! horizontal locations logical :: luse ! flag indicating if ob is used in pen. integer(i_kind) :: idv,iob ! device id and obs index for sorting integer(i_kind),dimension(:),pointer :: ich end type rad_ob_type type rad_ob_head integer(i_kind):: n_alloc=0 type(rad_ob_type),pointer :: head => NULL() end type rad_ob_head type pcp_ob_type sequence type(pcp_ob_type),pointer :: llpoint => NULL() type(obs_diag), pointer :: diags => NULL() real(r_kind) :: obs ! observed precipitation value real(r_kind) :: err2 ! error variances squared real(r_kind) :: raterr2 ! ratio of error variances squared real(r_kind) :: time ! observation time in sec real(r_kind) :: ges ! guess observation value real(r_kind) :: wij(4) ! horizontal interpolation weights real(r_kind),dimension(:),pointer :: predp => NULL() ! predictors (npredp) real(r_kind),dimension(:),pointer :: dpcp_dvar => NULL() ! error variances squared (nsig5) integer(i_kind) :: ij(4) ! horizontal locations integer(i_kind) :: icxp ! type of precipitation rate observation logical :: luse ! flag indicating if ob is used in pen. integer(i_kind) :: idv,iob ! device id and obs index for sorting end type pcp_ob_type type pcp_ob_head integer(i_kind):: n_alloc=0 type(pcp_ob_type),pointer :: head => NULL() end type pcp_ob_head type lag_ob_type sequence type(lag_ob_type),pointer :: llpoint => NULL() type(obs_diag), pointer :: diag_lon => NULL() type(obs_diag), pointer :: diag_lat => NULL() real(r_kind) :: res_lon ! residual real(r_kind) :: res_lat ! residual real(r_kind) :: err2_lon ! error squared real(r_kind) :: err2_lat ! error squared real(r_kind) :: raterr2 ! square of ratio of final obs error ! to original obs error real(r_kind) :: obslon ! observed longitude (rad) real(r_kind) :: obslat ! observed latitude (rad) real(r_kind) :: geslon ! guessed longitude (rad) real(r_kind) :: geslat ! guessed latitude (rad) real(r_kind) ,dimension(:),allocatable :: specr ! TL parameter real(r_kind) :: time ! observation time in sec real(r_kind) :: b ! variational quality control parameter real(r_kind) :: pg ! variational quality control parameter integer(i_kind),dimension(:),allocatable :: speci ! TL parameter integer(i_kind) :: intnum ! internal number of balloon logical :: luse ! flag indicating if ob is used in pen. integer(i_kind) :: idv,iob ! device id and obs index for sorting end type lag_ob_type type lag_ob_head integer(i_kind):: n_alloc=0 type(lag_ob_type),pointer :: head => NULL() end type lag_ob_head ! lfm -------------------------------------------------------------------- type obs_handle sequence type(ps_ob_type),pointer :: ps => NULL() type(t_ob_type),pointer :: t => NULL() type(w_ob_type),pointer :: w => NULL() type(q_ob_type),pointer :: q => NULL() type(spd_ob_type),pointer :: spd => NULL() type(srw_ob_type),pointer :: srw => NULL() type(rw_ob_type),pointer :: rw => NULL() type(dw_ob_type),pointer :: dw => NULL() type(sst_ob_type),pointer :: sst => NULL() type(pw_ob_type),pointer :: pw => NULL() type(oz_ob_type),pointer :: oz => NULL() type(o3l_ob_type),pointer :: o3l => NULL() type(gps_ob_type),pointer :: gps => NULL() type(rad_ob_type),pointer :: rad => NULL() type(pcp_ob_type),pointer :: pcp => NULL() type(tcp_ob_type),pointer :: tcp => NULL() type(lag_ob_type),pointer :: lag => NULL() end type obs_handle ! Declare types type(ps_ob_head),dimension(:),allocatable :: pshead type(ps_ob_head),dimension(:),allocatable :: pstail type(ps_ob_type),pointer :: psptr => NULL() type(tcp_ob_head),dimension(:),allocatable :: tcphead type(tcp_ob_head),dimension(:),allocatable :: tcptail type(tcp_ob_type),pointer :: tcpptr => NULL() type(t_ob_head),dimension(:),allocatable :: thead type(t_ob_head),dimension(:),allocatable :: ttail type(t_ob_type),pointer :: tptr => NULL() type(w_ob_head),dimension(:),pointer :: whead type(w_ob_head),dimension(:),pointer :: wtail type(w_ob_type),pointer :: wptr => NULL() type(q_ob_head),dimension(:),pointer :: qhead type(q_ob_head),dimension(:),pointer :: qtail type(q_ob_type),pointer :: qptr => NULL() type(spd_ob_head),dimension(:),pointer :: spdhead type(spd_ob_head),dimension(:),pointer :: spdtail type(spd_ob_type),pointer :: spdptr => NULL() type(srw_ob_head),dimension(:),pointer :: srwhead type(srw_ob_head),dimension(:),pointer :: srwtail type(srw_ob_type),pointer :: srwptr => NULL() type(rw_ob_head),dimension(:),pointer :: rwhead type(rw_ob_head),dimension(:),pointer :: rwtail type(rw_ob_type),pointer :: rwptr => NULL() type(dw_ob_head),dimension(:),pointer :: dwhead type(dw_ob_head),dimension(:),pointer :: dwtail type(dw_ob_type),pointer :: dwptr => NULL() type(sst_ob_head),dimension(:),pointer :: ssthead type(sst_ob_head),dimension(:),pointer :: ssttail type(sst_ob_type),pointer :: sstptr => NULL() type(pcp_ob_head),dimension(:),pointer :: pcphead type(pcp_ob_head),dimension(:),pointer :: pcptail type(pcp_ob_type),pointer :: pcpptr => NULL() type(pw_ob_head),dimension(:),pointer :: pwhead type(pw_ob_head),dimension(:),pointer :: pwtail type(pw_ob_type),pointer :: pwptr => NULL() type(oz_ob_head),dimension(:),pointer :: ozhead type(oz_ob_head),dimension(:),pointer :: oztail type(oz_ob_type),pointer :: ozptr => NULL() type(o3l_ob_head),dimension(:),pointer :: o3lhead type(o3l_ob_head),dimension(:),pointer :: o3ltail type(o3l_ob_type),pointer :: o3lptr => NULL() type(gps_ob_head),dimension(:),pointer :: gpshead type(gps_ob_head),dimension(:),pointer :: gpstail type(gps_ob_type),pointer :: gpsptr => NULL() type(gps_all_ob_head),dimension(:),pointer :: gps_allhead type(gps_all_ob_head),dimension(:),pointer :: gps_alltail type(gps_all_ob_type),pointer :: gps_allptr => NULL() type(rad_ob_head),dimension(:),pointer :: radhead type(rad_ob_head),dimension(:),pointer :: radtail type(rad_ob_type),pointer :: radptr => NULL() type(lag_ob_head),dimension(:),pointer :: laghead type(lag_ob_head),dimension(:),pointer :: lagtail type(lag_ob_type),pointer :: lagptr => NULL() type(obs_handle),dimension(:),pointer :: yobs type(obs_diags), pointer :: obsdiags(:,:) ! (nobs_type,nobs_bins) type(obs_diag), pointer :: obsptr ! Declare interfaces interface destroyobs; module procedure destroyobs_; end interface ! Declare global variables real(r_kind) perturb_fact,time_window_max,time_offset real(r_kind),dimension(ndatmax):: dval,dmesh,time_window integer(i_kind) grids_dim,nchan_total,ianldate integer(i_kind) ndat,ndat_types,ndat_times,nprof_gps integer(i_kind) lunobs_obs,nloz_v6,nloz_v8,nobskeep integer(i_kind) iout_rad,iout_pcp,iout_t,iout_q,iout_uv, & iout_oz,iout_ps,iout_pw,iout_rw integer(i_kind) iout_dw,iout_srw,iout_gps,iout_sst,iout_tcp,iout_lag integer(i_kind) mype_t,mype_q,mype_uv,mype_ps,mype_pw, & mype_rw,mype_dw,mype_srw,mype_gps,mype_sst, & mype_tcp,mype_lag integer(i_kind),dimension(5):: iadate integer(i_kind),dimension(ndatmax):: dsfcalc,dthin,ipoint integer(i_kind),allocatable,dimension(:):: nsat1,mype_diaghdr integer(i_kind),allocatable :: obscounts(:,:) character(128) obs_setup character(128) dirname character(128) obs_input_common character(14),dimension(ndatmax):: obsfile_all character(10),dimension(ndatmax):: dtype,ditype,dplat character(13),dimension(ndatmax):: dfile character(20),dimension(ndatmax):: dsis character(len=20) :: cobstype(nobs_type) logical oberrflg,oberror_tune,perturb_obs,ref_obs,sfcmodel,dtbduv_on logical blacklst,lobsdiagsave,lobsdiag_allocated,lobskeep,lsaveobsens logical lobserver,l_do_adjoint logical,dimension(0:50):: write_diag logical offtime_data logical hilbert_curve logical lread_obs_save logical lread_obs_skip character(len=*),parameter:: myname='obsmod' contains subroutine init_obsmod_dflts !$$$ subprogram documentation block ! . . . . ! subprogram: init_obsmod_dflts ! prgmmr: derber org: np23 date: 2003-09-25 ! ! abstract: set defaults for observation related variables ! ! program history log: ! 2003-09-25 derber ! 2004-05-13 treadon, documentation ! 2004-07-23 derber - add conventional sst observations ! 2004-12-22 treadon - add initialization of write_diag ! 2005-02-07 treadon - change mype_* for obs types ! 2005-02-18 treadon - change write_diag(1) default to .true. ! 2005-05-27 yanqiu - added obs_sen ! 2005-05-27 derber - add oberrflg ! 2005-06-14 wu - add OMI oz (ozo) ! 2006-10-25 sienkiewicz - introduce blacklst ! 2007-05-03 todling - use values def above as indexes to cobstype ! 2008-11-25 todling - remove line-by-line adj triggers ! ! input argument list: ! ! output argument list: ! ! attributes: ! language: f90 ! machine: ibm rs/6000 sp ! !$$$ end documentation block implicit none integer(i_kind) i ! Set logical flag perturb_obs = .false. ! .true. = perturb observations oberror_tune = .false. ! .true. = tune oberror perturb_fact = one do i=0,50 write_diag(i)=.false. end do write_diag(1)=.true. lobsdiagsave=.false. lobsdiag_allocated=.false. lobskeep=.false. nobskeep=0 lsaveobsens=.false. l_do_adjoint=.true. ! .true. = apply H^T when in int routines oberrflg = .false. sfcmodel = .false. ! .false. = do not use boundary layer model dtbduv_on = .true. ! .true. = use microwave dTb/duv in inner loop if (l4dvar) then offtime_data = .true. ! .true. = ignore difference in obs ref time ! and analysis time else offtime_data = .false. ! .false. = code fails if data files contain ref time ! different from analysis time endif blacklst = .false. lobserver = .false. ! when .t., calculate departure vectors only ! Specify unit numbers to which to write data counts, indication of quality control ! decisions, and statistics summary of innovations. For radiance data also write ! bias correction coefficients to this unit (iout_rad) iout_ps=201 ! surface pressure iout_uv=202 ! u,v wind components iout_t=203 ! virtual temperature iout_q=204 ! moisure (specific humidity) iout_pw=205 ! total column water (precipitable water) iout_oz=206 ! ozone iout_rad=207 ! radiance (brightness temperature) iout_pcp=208 ! precipitation rate iout_rw=209 ! radar radial wind iout_dw=210 ! doppler lidar wind iout_srw=211 ! radar superob wind iout_gps=212 ! gps refractivity or bending angle iout_sst=213 ! conventional sst iout_tcp=214 ! synthetic tc-mslp iout_lag=215 ! lagrangian tracers mype_ps = npe-1 ! surface pressure mype_uv = max(0,npe-2) ! u,v wind components mype_t = max(0,npe-3) ! virtual temperature mype_q = max(0,npe-4) ! moisture (specific humidity) mype_pw = max(0,npe-5) ! total column water mype_rw = max(0,npe-6) ! radar radial wind mype_dw = max(0,npe-7) ! doppler lidar wind mype_srw= max(0,npe-8) ! radar superob wind mype_gps= max(0,npe-9) ! gps refractivity or bending angle mype_sst= max(0,npe-10) ! conventional sst mype_tcp= max(0,npe-11) ! synthetic tc-mslp mype_lag= max(0,npe-12) ! lagrangian tracers ! Initialize arrays used in namelist obs_input ndat = ndatmax ! number of observation types (files) time_window_max = three ! set maximum time window to +/-three hours do i=1,ndat dfile(i) = ' ' ! local file name from which to read observatinal data dtype(i) = ' ' ! character string identifying type of observation ditype(i)= ' ' ! character string identifying group type of ob dplat(i) = ' ' ! currently contains satellite id (no meaning for non-sat data) dsis(i) = ' ' ! sensor/instrument/satellite identifier for info files dsfcalc(i)=0 ! use orig bilinear FOV surface calculation (routine deter_sfc) ipoint(i)= 0 ! default pointer (values set in gsisub) dthin(i) = 1 ! thinning flag (1=thinning on; otherwise off) time_window(i) = time_window_max ! default to maximum time window write(obsfile_all(i),100) i ! name of scratch file to hold obs data end do 100 format('obs_input.',i4.4) ! Other initializations nloz_v6 = 12 ! number of "levels" in ozone version8 data nloz_v8 = 21 ! number of "levels" in ozone version6 data lunobs_obs = 2 ! unit to which to write/read information ! related to brightness temperature and ! precipitation rate observations grids_dim= 161 ! grid points for integration of GPS bend nprof_gps = 0 ! Define a name for obs types cobstype( i_ps_ob_type)="surface pressure " ! ps_ob_type cobstype( i_t_ob_type)="temperature " ! t_ob_type cobstype( i_w_ob_type)="wind " ! w_ob_type cobstype( i_q_ob_type)="moisture " ! q_ob_type cobstype(i_spd_ob_type)="wind speed " ! spd_ob_type cobstype(i_srw_ob_type)="srw " ! srw_ob_type cobstype( i_rw_ob_type)="radial wind " ! rw_ob_type cobstype( i_dw_ob_type)="doppler wind " ! dw_ob_type cobstype(i_sst_ob_type)="sst " ! sst_ob_type cobstype( i_pw_ob_type)="precipitable water " ! pw_ob_type cobstype(i_pcp_ob_type)="precipitation " ! pcp_ob_type cobstype( i_oz_ob_type)="ozone " ! oz_ob_type cobstype(i_o3l_ob_type)="level ozone " ! o3l_ob_type cobstype(i_gps_ob_type)="gps " ! gps_ob_type cobstype(i_rad_ob_type)="radiance " ! rad_ob_type cobstype(i_tcp_ob_type)="tcp (tropic cyclone)" ! tcp_ob_type cobstype(i_lag_ob_type)="lagrangian tracer " ! lag_ob_type hilbert_curve=.false. obs_input_common = 'obs_input.common' lread_obs_save = .false. lread_obs_skip = .false. return end subroutine init_obsmod_dflts subroutine init_directories(mype) !$$$ subprogram documentation block ! . . . . ! subprogram: create sub-directories ! prgmmr: kleist org: np23 date: 2007-06-08 ! ! abstract: set-up name for and create sub-directories to ! hold observation and diagnostic files. Doing ! so on IBM SP reduces wall clock and stabilizes ! run times ! ! program history log: ! 2007-06-08 kleist ! 2008-06-02 safford - add doc block end ! ! input argument list: ! mype - pe task id ! ! output argument list: ! ! attributes: ! language: f90 ! machine: ibm rs/6000 sp ! !$$$ end documentation block implicit none integer(i_kind),intent(in ) :: mype character(len=144):: command character(len=8):: pe_name #ifdef ibm_sp write(pe_name,'(i4.4)') mype dirname = 'dir.'//trim(pe_name)//'/' command = 'mkdir -m 755 ' // trim(dirname) call system(command) #else write(pe_name,100) mype 100 format('pe',i4.4,'.') dirname= trim(pe_name) #endif return end subroutine init_directories subroutine create_obsmod_vars !$$$ subprogram documentation block ! . . . . ! subprogram: create_obsmod_vars ! prgmmr: derber org: np23 date: 2003-09-25 ! ! abstract: allocate arrays to hold observation related information ! ! program history log: ! 2003-09-25 derber ! 2004-05-13 treadon, documentation ! ! input argument list: ! ! output argument list: ! ! attributes: ! language: f90 ! machine: ibm rs/6000 sp ! !$$$ end documentation block use gsi_4dvar, only: nobs_bins implicit none allocate (nsat1(ndat),mype_diaghdr(ndat)) ALLOCATE(thead (nobs_bins)) ALLOCATE(ttail (nobs_bins)) ALLOCATE(pshead (nobs_bins)) ALLOCATE(pstail (nobs_bins)) ALLOCATE(tcphead(nobs_bins)) ALLOCATE(tcptail(nobs_bins)) ALLOCATE(whead (nobs_bins)) ALLOCATE(wtail (nobs_bins)) ALLOCATE(qhead (nobs_bins)) ALLOCATE(qtail (nobs_bins)) ALLOCATE(spdhead(nobs_bins)) ALLOCATE(spdtail(nobs_bins)) ALLOCATE(srwhead(nobs_bins)) ALLOCATE(srwtail(nobs_bins)) ALLOCATE(rwhead (nobs_bins)) ALLOCATE(rwtail (nobs_bins)) ALLOCATE(dwhead (nobs_bins)) ALLOCATE(dwtail (nobs_bins)) ALLOCATE(ssthead(nobs_bins)) ALLOCATE(ssttail(nobs_bins)) ALLOCATE(pcphead(nobs_bins)) ALLOCATE(pcptail(nobs_bins)) ALLOCATE(pwhead (nobs_bins)) ALLOCATE(pwtail (nobs_bins)) ALLOCATE(ozhead (nobs_bins)) ALLOCATE(oztail (nobs_bins)) ALLOCATE(o3lhead(nobs_bins)) ALLOCATE(o3ltail(nobs_bins)) ALLOCATE(radhead(nobs_bins)) ALLOCATE(radtail(nobs_bins)) ALLOCATE(gpshead(nobs_bins)) ALLOCATE(gpstail(nobs_bins)) ALLOCATE(gps_allhead(nobs_bins)) ALLOCATE(gps_alltail(nobs_bins)) ALLOCATE(laghead(nobs_bins)) ALLOCATE(lagtail(nobs_bins)) ALLOCATE(yobs(nobs_bins)) ALLOCATE(obsdiags(nobs_type,nobs_bins)) return end subroutine create_obsmod_vars ! ---------------------------------------------------------------------- subroutine init_obsmod_vars(mype) !$$$ subprogram documentation block ! . . . . ! subprogram: init_obsmod_vars ! prgmmr: tremolet org: GMAO date: 2007-02-02 ! ! abstract: set values for observation related variables ! ! program history log: ! 2007-02-02 tremolet ! ! input argument list: ! ! output argument list: ! ! attributes: ! language: f90 ! !$$$ end documentation block use gsi_4dvar, only: nhr_assimilation use gridmod, only: regional implicit none integer(i_kind),intent(in ) :: mype integer(i_kind) ii,jj,ioff character(len=2) :: cind logical :: limit ! Because obs come in 6-hour batches ndat_times=nhr_assimilation/6 if(regional)ndat_times = nhr_assimilation/3 ! if (ndat_times*6/=nhr_assimilation) then ! write(6,*)'OBSMOD: ***ERROR*** in assimilation time window setting; ', & ! ' must be a multiple of 6hrs: ndat_times= ', ndat_times, & ! ' nhr_assimilation= ', nhr_assimilation, & ! ' ***STOP IN OBSMOD***' ! call stop2(70) ! endif ndat_types=ndat ndat=ndat_times*ndat_types ! The following was in gsimain. ! Ensure time window specified in obs_input does not exceed ! specified maximum value limit=.false. do ii=1,ndat_types if (time_window(ii)>time_window_max) then time_window(ii) = time_window_max limit = .true. endif end do if (mype==0 .and. limit) & write(6,*)'INIT_OBSMOD_VARS: reset time window for one or ',& 'more OBS_INPUT entries to ',time_window_max ! Initialize arrays in obs_input if more than one synoptic time IF (ndat_times>1) THEN ! Copy other things DO ii=2,ndat_times write(cind,'(i2.2)')ii ioff=(ii-1)*ndat_types DO jj=1,ndat_types dfile (ioff+jj) = trim(dfile(jj))//'.'//cind !_RT??? dmesh (ioff+jj) = dmesh(jj) dtype (ioff+jj) = dtype(jj) ditype(ioff+jj) = ditype(jj) dplat (ioff+jj) = dplat(jj) dsis (ioff+jj) = dsis(jj) ipoint(ioff+jj) = ipoint(jj) dthin (ioff+jj) = dthin(jj) dval (ioff+jj) = dval(jj) time_window(ioff+jj) = time_window(jj) ENDDO ENDDO ! Then change name for first time slot IF (ndat_times>1) THEN DO jj=1,ndat_types dfile(jj) = trim(dfile(jj))//'.01' ENDDO ENDIF ENDIF IF (mype==0) THEN write(6,*)'INIT_OBSMOD_VARS: ndat_times,ndat_types,ndat=', & & ndat_times,ndat_types,ndat write(6,*)'INIT_OBSMOD_VARS: nhr_assimilation=',nhr_assimilation ENDIF return end subroutine init_obsmod_vars ! ---------------------------------------------------------------------- subroutine destroyobs_ ( skipit ) !$$$ subprogram documentation block ! . . . . ! subprogram: destroyobs ! prgmmr: derber org: np23 date: 2003-09-25 ! ! abstract: deallocate arrays that hold observation information for ! use in outer and inner loops ! ! program history log: ! 2003-09-25 derber ! 2004-05-13 treadon, documentation ! 2004-07-23 derber - add conventional sst observations ! 2005-06-14 wu - add OMI oz (ozo) ! ! input argument list: ! skipit ! ! output argument list: ! ! attributes: ! language: f90 ! machine: ibm rs/6000 sp ! !$$$ end documentation block use gsi_4dvar, only: nobs_bins implicit none logical,optional,intent(in ) :: skipit integer(i_kind) :: ii,jj,istatus logical :: skipit_ skipit_=.false. if (present(skipit)) then skipit_=skipit endif do ii=1,nobs_bins ttail(ii)%head => thead(ii)%head do while (associated(ttail(ii)%head)) thead(ii)%head => ttail(ii)%head%llpoint deallocate(ttail(ii)%head,stat=istatus) if (istatus/=0) write(6,*)'DESTROYOBS: deallocate error for t, istatus=',istatus ttail(ii)%head => thead(ii)%head end do end do do ii=1,nobs_bins pwtail(ii)%head => pwhead(ii)%head do while (associated(pwtail(ii)%head)) pwhead(ii)%head => pwtail(ii)%head%llpoint deallocate(pwtail(ii)%head%dp,stat=istatus) if (istatus/=0) write(6,*)'DESTROYOBS: deallocate error for pw arrays, istatus=',istatus deallocate(pwtail(ii)%head,stat=istatus) if (istatus/=0) write(6,*)'DESTROYOBS: deallocate error for pw, istatus=',istatus pwtail(ii)%head => pwhead(ii)%head end do end do do ii=1,nobs_bins pstail(ii)%head => pshead(ii)%head do while (associated(pstail(ii)%head)) pshead(ii)%head => pstail(ii)%head%llpoint deallocate(pstail(ii)%head,stat=istatus) if (istatus/=0) write(6,*)'DESTROYOBS: deallocate error for ps, istatus=',istatus pstail(ii)%head => pshead(ii)%head end do end do do ii=1,nobs_bins wtail(ii)%head => whead(ii)%head do while (associated(wtail(ii)%head)) whead(ii)%head => wtail(ii)%head%llpoint deallocate(wtail(ii)%head,stat=istatus) if (istatus/=0) write(6,*)'DESTROYOBS: deallocate error for w, istatus=',istatus wtail(ii)%head => whead(ii)%head end do end do do ii=1,nobs_bins qtail(ii)%head => qhead(ii)%head do while (associated(qtail(ii)%head)) qhead(ii)%head => qtail(ii)%head%llpoint deallocate(qtail(ii)%head,stat=istatus) if (istatus/=0) write(6,*)'DESTROYOBS: deallocate error for q, istatus=',istatus qtail(ii)%head => qhead(ii)%head end do end do do ii=1,nobs_bins spdtail(ii)%head => spdhead(ii)%head do while (associated(spdtail(ii)%head)) spdhead(ii)%head => spdtail(ii)%head%llpoint deallocate(spdtail(ii)%head,stat=istatus) if (istatus/=0) write(6,*)'DESTROYOBS: deallocate error for spd, istatus=',istatus spdtail(ii)%head => spdhead(ii)%head end do end do do ii=1,nobs_bins srwtail(ii)%head => srwhead(ii)%head do while (associated(srwtail(ii)%head)) srwhead(ii)%head => srwtail(ii)%head%llpoint deallocate(srwtail(ii)%head,stat=istatus) if (istatus/=0) write(6,*)'DESTROYOBS: deallocate error for srw, istatus=',istatus srwtail(ii)%head => srwhead(ii)%head end do end do do ii=1,nobs_bins rwtail(ii)%head => rwhead(ii)%head do while (associated(rwtail(ii)%head)) rwhead(ii)%head => rwtail(ii)%head%llpoint deallocate(rwtail(ii)%head,stat=istatus) if (istatus/=0) write(6,*)'DESTROYOBS: deallocate error for rw, istatus=',istatus rwtail(ii)%head => rwhead(ii)%head end do end do do ii=1,nobs_bins dwtail(ii)%head => dwhead(ii)%head do while (associated(dwtail(ii)%head)) dwhead(ii)%head => dwtail(ii)%head%llpoint deallocate(dwtail(ii)%head,stat=istatus) if (istatus/=0) write(6,*)'DESTROYOBS: deallocate error for dw, istatus=',istatus dwtail(ii)%head => dwhead(ii)%head end do end do do ii=1,nobs_bins ssttail(ii)%head => ssthead(ii)%head do while (associated(ssttail(ii)%head)) ssthead(ii)%head => ssttail(ii)%head%llpoint deallocate(ssttail(ii)%head,stat=istatus) if (istatus/=0) write(6,*)'DESTROYOBS: deallocate error for sst, istatus=',istatus ssttail(ii)%head => ssthead(ii)%head end do end do do ii=1,nobs_bins oztail(ii)%head => ozhead(ii)%head do while (associated(oztail(ii)%head)) ozhead(ii)%head => oztail(ii)%head%llpoint deallocate(oztail(ii)%head%res, oztail(ii)%head%wij,& oztail(ii)%head%err2,oztail(ii)%head%raterr2, & oztail(ii)%head%prs,oztail(ii)%head%ipos,stat=istatus) if (istatus/=0) write(6,*)'DESTROYOBS: deallocate error for oz arrays, istatus=',istatus deallocate(oztail(ii)%head,stat=istatus) if (istatus/=0) write(6,*)'DESTROYOBS: deallocate error for oz, istatus=',istatus oztail(ii)%head => ozhead(ii)%head end do end do do ii=1,nobs_bins o3ltail(ii)%head => o3lhead(ii)%head do while (associated(o3ltail(ii)%head)) o3lhead(ii)%head => o3ltail(ii)%head%llpoint deallocate(o3ltail(ii)%head,stat=istatus) if (istatus/=0) write(6,*)'DESTROYOBS: deallocate error for o3l, istatus=',istatus o3ltail(ii)%head => o3lhead(ii)%head end do end do do ii=1,nobs_bins gpstail(ii)%head => gpshead(ii)%head do while (associated(gpstail(ii)%head)) gpshead(ii)%head => gpstail(ii)%head%llpoint deallocate(gpstail(ii)%head%jac_q,gpstail(ii)%head%jac_t, & gpstail(ii)%head%jac_p, & gpstail(ii)%head%ij,stat=istatus) if (istatus/=0) write(6,*)'DESTROYOBS: deallocate error for gps arrays, istatus=',istatus deallocate(gpstail(ii)%head,stat=istatus) if (istatus/=0) write(6,*)'DESTROYOBS: deallocate error for gps, istatus=',istatus gpstail(ii)%head => gpshead(ii)%head end do end do do ii=1,nobs_bins radtail(ii)%head => radhead(ii)%head do while (associated(radtail(ii)%head)) radhead(ii)%head => radtail(ii)%head%llpoint deallocate(radtail(ii)%head%res,radtail(ii)%head%err2, & radtail(ii)%head%raterr2,radtail(ii)%head%pred, & radtail(ii)%head%dtb_dvar, & radtail(ii)%head%icx,stat=istatus) if (istatus/=0) write(6,*)'DESTROYOBS: deallocate error for rad arrays, istatus=',istatus deallocate(radtail(ii)%head,stat=istatus) if (istatus/=0) write(6,*)'DESTROYOBS: deallocate error for rad, istatus=',istatus radtail(ii)%head => radhead(ii)%head end do end do do ii=1,nobs_bins pcptail(ii)%head => pcphead(ii)%head do while (associated(pcptail(ii)%head)) pcphead(ii)%head => pcptail(ii)%head%llpoint deallocate(pcptail(ii)%head%predp,pcptail(ii)%head%dpcp_dvar,stat=istatus) if (istatus/=0) write(6,*)'DESTROYOBS: deallocate error for pcp arrays, istatus=',istatus deallocate(pcptail(ii)%head,stat=istatus) if (istatus/=0) write(6,*)'DESTROYOBS: deallocate error for pcp, istatus=',istatus pcptail(ii)%head => pcphead(ii)%head end do end do do ii=1,nobs_bins tcptail(ii)%head => tcphead(ii)%head do while (associated(tcptail(ii)%head)) tcphead(ii)%head => tcptail(ii)%head%llpoint deallocate(tcptail(ii)%head,stat=istatus) if (istatus/=0) write(6,*)'DESTROYOBS: deallocate error for tcp, istatus=',istatus tcptail(ii)%head => tcphead(ii)%head end do end do do ii=1,nobs_bins lagtail(ii)%head => laghead(ii)%head do while (associated(lagtail(ii)%head)) laghead(ii)%head => lagtail(ii)%head%llpoint deallocate(lagtail(ii)%head%speci,lagtail(ii)%head%specr,stat=istatus) if (istatus/=0) write(6,*)'DESTROYOBS: deallocate error for lag arrays, istatus=',istatus deallocate(lagtail(ii)%head,stat=istatus) if (istatus/=0) write(6,*)'DESTROYOBS: deallocate error for lag, istatus=',istatus lagtail(ii)%head => laghead(ii)%head end do end do if (l4dvar) then if (.not. skipit_) then do ii=1,nobs_bins do jj=1,nobs_type obsptr => obsdiags(jj,ii)%head do while (associated(obsptr)) obsdiags(jj,ii)%head => obsptr%next deallocate(obsptr%nldepart,obsptr%tldepart,obsptr%obssen,obsptr%muse) deallocate(obsptr) obsptr => obsdiags(jj,ii)%head enddo enddo enddo lobsdiag_allocated=.false. endif endif if (allocated(obscounts)) deallocate(obscounts) return end subroutine destroyobs_ subroutine destroy_obsmod_vars !$$$ subprogram documentation block ! . . . . ! subprogram: destroyb_obsmod_vars ! prgmmr: derber org: np23 date: 2003-09-25 ! ! abstract: deallocate arrays that hold observation information ! ! program history log: ! 2003-09-25 derber ! 2004-05-13 treadon, documentation ! ! input argument list: ! ! output argument list: ! ! attributes: ! language: f90 ! machine: ibm rs/6000 sp ! !$$$ end documentation block implicit none deallocate(nsat1,mype_diaghdr) return end subroutine destroy_obsmod_vars real(r_kind) function ran01dom() !$$$ subprogram documentation block ! . . . . ! subprogram: ran01dom generate a random number with mean:0 variance:1 ! prgmmr: wu org: np22 date: 2005-10-27 ! ! abstract: generate a random number with mean:0 variance:1 ! ! program history log: ! 2005-10-27 wu ! ! input argument list: ! ! output argument list: ! ! attributes: ! language: f90 ! machine: ibm RS/6000 SP ! !$$$ end documentation block use constants, only: five implicit none integer(i_kind):: j real(r_kind),dimension(10):: a call random_number(a) ran01dom=zero do j=1,10 ran01dom=ran01dom+a(j) enddo ran01dom=(ran01dom-five)/0.912345_r_kind return end function ran01dom subroutine destroy_genstats_gps !$$$ subprogram documentation block ! . . . . ! subprogram: destroy_genstats_gps ! prgmmr: treadon org: np20 date: 2005-12-21 ! ! abstract: deallocate arrays holding gps information ! ! program history log: ! 2005-12-21 treadon ! ! input argument list: ! ! output argument list: ! ! attributes: ! language: f90 ! machine: ibm rs/6000 sp ! !$$$ end documentation block use gsi_4dvar, only: nobs_bins implicit none integer(i_kind):: istatus,ii do ii=1,nobs_bins gps_alltail(ii)%head => gps_allhead(ii)%head do while (associated(gps_alltail(ii)%head)) gps_allhead(ii)%head => gps_alltail(ii)%head%llpoint deallocate(gps_alltail(ii)%head,stat=istatus) if (istatus/=0) write(6,*)'DESTROY_GENSTATS_GPS: deallocate error for gps_all, istatus=',istatus gps_alltail(ii)%head => gps_allhead(ii)%head end do end do return end subroutine destroy_genstats_gps ! ---------------------------------------------------------------------- subroutine inquire_obsdiags(kiter) !$$$ subprogram documentation block ! . . . . ! subprogram: inquire_obsdiags ! prgmmr: ! ! abstract: ! ! program history log: ! 2009-08-07 lueken - added subprogram doc block ! ! input argument list: ! kiter ! ! output argument list: ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none integer(i_kind), intent(in ) :: kiter real(r_kind) :: sizei, sizer, sizel, sizep, ziter, zsize, ztot integer(i_kind) :: ii,jj,iobsa(2),iobsb(2) ! Any better way to determine size or i_kind, r_kind, etc... ? sizei=four sizer=8.0_r_kind sizel=one sizep=four iobsa(:)=0 do ii=1,size(obsdiags,2) do jj=1,size(obsdiags,1) obsptr => obsdiags(jj,ii)%head do while (associated(obsptr)) iobsa(1)=iobsa(1)+1 if (ANY(obsptr%muse(:))) iobsa(2)=iobsa(2)+1 obsptr => obsptr%next enddo enddo enddo call mpi_reduce(iobsa,iobsb,2,mpi_itype,mpi_max,0,mpi_comm_world,ierror) if (mype==0) then ziter=real(kiter,r_kind) zsize = sizer*(three*ziter+two) + sizei + sizel*(ziter+one) + sizep*five ztot=real(iobsb(1),r_kind)*zsize ztot=ztot/(1024.0_r_kind*1024.0_r_kind) write(6,*)'obsdiags: Bytes per element=',NINT(zsize) write(6,*)'obsdiags: length total, used=',iobsb(1),iobsb(2) write(6,'(A,F8.1,A)')'obsdiags: Estimated memory usage= ',ztot,' Mb' endif end subroutine inquire_obsdiags ! ---------------------------------------------------------------------- end module obsmod