!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !====================================================================== ! BEGINNING OF ENSDA_INIT !====================================================================== subroutine ensda_init & (A,n,dt_model,ifm,im,jm,lm,lg,ls, & iuc,ivc,iwc,ipc,ithp,irtp,irrp,irpp,irsp,irap,irgp, & irhp,ircp, & irv,itheta) ! ********************************************************************** ! ! PROGRAM: ensda_init read and write initial ensemble data assimilation fields ! PRGMMR: D. ZUPANSKI ORG: CIRA/CSU DATE: 2004-06-17 ! ! ! REVISION HISTORY: ! ! 05/10/2004 ..... M. ZUPANSKI (SWM) ! 06/17/2004 ..... D. ZUPANSKI (RAMS) ! !----------------------------------------------------------------------- use ensda_variables implicit NONE integer :: n integer :: ifm,im,jm,lm,lg,ls integer :: iuc,ivc,iwc,ipc,ithp,irtp, & irrp,irpp,irsp,irap,irgp, & irhp,ircp, & irv,itheta real,dimension(*) :: A real :: dt_model real :: xparam !=========================================================== nbias=0 num_bias=0 open_ic=.FALSE. open_param=.FALSE. open_bias=.FALSE. call read_write_ensda_namelists & (ifm,im,jm,lm,lg,ls,xparam) !----fcst_length(min), dt_model(sec)----------- ntime=int(fcst_length/(dt_model/60.)) !----------- write(*,*) "ensda_init: n=",n write(*,*) "ensda_init: dt_model=",dt_model write(*,*) "ensda_init: im,jm,lm,lg,ls=",im,jm,lm,lg,ls ! write(*,*) "ensda_init: u min,max=",minval(u),maxval(u) ! write(*,*) "ensda_init: v min,max=",minval(v),maxval(v) ! write(*,*) "ensda_init: w min,max=",minval(w),maxval(w) write(*,*) "ensda_init: xparam=",xparam call write_history_format & (A,n,dt_model,ifm,im,jm,lm,lg,ls, & iuc,ivc,iwc,ipc,ithp,irtp,irrp,irpp,irsp,irap,irgp, & irhp,ircp, & irv,itheta) call write_history_nonformat & (A,ifm,im,jm,lm,lg,ls, & iuc,ivc,iwc,ipc,ithp,irtp,irrp,irpp,irsp,irap,irgp, & irhp,ircp, & irv,itheta) call write_model_ic & (A,ifm,im,jm,lm,lg,ls, & iuc,ivc,iwc,ipc,ithp,irtp,irrp,irpp,irsp,irap,irgp, & irhp,ircp, & irv,itheta) call write_model_param & (xparam) do while(nbias.le.num_bias) call write_model_bias & (ifm,im,jm,lm,lg,ls) nbias=nbias+1 enddo end subroutine ensda_init !====================================================================== ! END OF ENSDA_INIT !====================================================================== !====================================================================== ! BEGINNING OF INITIALIZE_ENSDA !====================================================================== subroutine initialize_ensda & (A,dt_model,ifm, & iuc,ivc,iwc,ipc,ithp,irtp,irrp,irpp,irsp,irap,irgp, & irhp,ircp, & irv,itheta,xparam) ! ********************************************************************** ! ! PROGRAM: ensda_init read and initialize ensemble data assimilation fields ! PRGMMR: M. ZUPANSKI ORG: CIRA/CSU DATE: 2004-05-10 ! ! ! REVISION HISTORY: ! ! 05/10/2004 ..... M. ZUPANSKI ! 06/21/2004 ..... D. ZUPANSKI: Adjust to RAMS model use ! !----------------------------------------------------------------------- use ensda_variables implicit NONE integer :: ifm,im,jm,lm,lg,ls integer :: iuc,ivc,iwc,ipc,ithp,irtp, & irrp,irpp,irsp,irap,irgp, & irhp,ircp, & irv,itheta real,dimension(*) :: A real :: dt_model real :: xparam integer :: nxyz !=========================================================== nbias=0 num_bias=0 open_ic=.FALSE. open_param=.FALSE. open_bias=.FALSE. call read_ensda_namelists & (ifm,im,jm,lm,lg,ls,xparam) !----fcst_length(min), dt_model(sec)----------- ntime=int(fcst_length/(dt_model/60.)) !----------- call read_history_nonformat & (A,ifm,im,jm,lm,lg,ls, & iuc,ivc,iwc,ipc,ithp,irtp,irrp,irpp,irsp,irap,irgp, & irhp,ircp, & irv,itheta) call read_model_ic & (A,ifm,im,jm,lm,lg,ls, & iuc,ivc,iwc,ipc,ithp,irtp,irrp,irpp,irsp,irap,irgp, & irhp,ircp, & irv,itheta) call read_model_param & (xparam) ! write(*,*) "initialize_ensda: n=",n write(*,*) "initialize_ensda: dt_model=",dt_model write(*,*) "initialize_ensda: ntime=",ntime write(*,*) "initialize_ensda: fcst_length=",fcst_length write(*,*) "initialize_ensda: im,jm,lm,lg,ls=",im,jm,lm,lg,ls nxyz=im*jm*lm write(*,*) "initialize_ensda: u min,max=",minval(a(iuc:iuc+nxyz-1)),maxval(a(iuc:iuc+nxyz-1)) write(*,*) "initialize_ensda: xparam=",xparam !-- read _phi as _bias (need to rename it after read) call read_model_bias & (ifm,im,jm,lm,lg,ls) if(num_bias.gt.0) then nerr=ntime/max(1,num_bias) else nerr=99999 end if if(associated(u_phi_ptr)) then u_phi(:,:,:)=u_bias(:,:,:) u_bias(:,:,:)=0.0 end if if(associated(v_phi_ptr)) then v_phi(:,:,:)=v_bias(:,:,:) v_bias(:,:,:)=0.0 end if if(associated(w_phi_ptr)) then w_phi(:,:,:)=w_bias(:,:,:) w_bias(:,:,:)=0.0 end if if(associated(exnr_phi_ptr)) then exnr_phi(:,:,:)=exnr_bias(:,:,:) exnr_bias(:,:,:)=0.0 end if if(associated(thetail_phi_ptr)) then thetail_phi(:,:,:)=thetail_bias(:,:,:) thetail_bias(:,:,:)=0.0 end if if(associated(r_total_phi_ptr)) then r_total_phi(:,:,:)=r_total_bias(:,:,:) r_total_bias(:,:,:)=0.0 end if if(associated(r_rain_phi_ptr)) then r_rain_phi(:,:,:)=r_rain_bias(:,:,:) r_rain_bias(:,:,:)=0.0 end if if(associated(r_pice_phi_ptr)) then r_pice_phi(:,:,:)=r_pice_bias(:,:,:) r_pice_bias(:,:,:)=0.0 end if if(associated(r_snow_phi_ptr)) then r_snow_phi(:,:,:)=r_snow_bias(:,:,:) r_snow_bias(:,:,:)=0.0 end if if(associated(r_agreg_phi_ptr)) then r_agreg_phi(:,:,:)=r_agreg_bias(:,:,:) r_agreg_bias(:,:,:)=0.0 end if if(associated(r_groupl_phi_ptr)) then r_groupl_phi(:,:,:)=r_groupl_bias(:,:,:) r_groupl_bias(:,:,:)=0.0 end if if(associated(r_hail_phi_ptr)) then r_hail_phi(:,:,:)=r_hail_bias(:,:,:) r_hail_bias(:,:,:)=0.0 end if if(associated(r_cldliq_phi_ptr)) then r_cldliq_phi(:,:,:)=r_cldliq_bias(:,:,:) r_cldliq_bias(:,:,:)=0.0 end if end subroutine initialize_ensda !====================================================================== ! END OF INITIALIZE_ENSDA !====================================================================== !====================================================================== ! BEGINNING OF READ_ENSDA_NAMELISTS !====================================================================== subroutine read_ensda_namelists & (ifm,im,jm,lm,lg,ls,xparam) ! ********************************************************************** ! * PROGRAM: read_ensda_namelists ! * ! * PRGMMR: D. ZUPANSKI ORG: CIRA/CSU DATE: 2003-12-12 ! * ! * ABSTRACT: Read namelists and other constant input files for use in ensda ! ! ! * PROGRAM LOG: ! * ! * 12/12/2003 ..... D. ZUPANSKI, M. ZUPANSKI ! * 05/06/2004 ..... M. ZUPANSKI: Adjust to SWM_CSU model use ! * 06/21/2004 ..... D. ZUPANSKI: Adjust to RAMS model use !==================================== use ensda_variables implicit none integer :: ifm,im,jm,lm,lg,ls real :: xparam integer :: IER,i integer,dimension(1) :: & NNXP,NNYP,NNZP,NNSOIL,NNSNOW ! model dims on model_dimension.name integer,dimension(:),allocatable :: & cvar_num_bias ! number of biases per cntrl vrbl character (len=9),dimension(:),allocatable :: & cvar_name ! cntrl vrbl name logical,dimension(:),allocatable :: & cvar_ic, &! init cond logical mask (per vrbl) cvar_param, &! empir param logical mask (per vrbl) cvar_bias ! model bias logical mask (per vrbl) !------------------------------ NAMELIST /MODEL_DIMENSION/ NNXP,NNYP,NNZP,NNSOIL,NNSNOW NAMELIST /LENGTH/ fcst_length NAMELIST /MODEL_CNSTS/ xparam,aa !===================================== !--- get model dimensions CLOSE(500) OPEN(UNIT=500,FILE='model_dimension.name',FORM='FORMATTED',IOSTAT=IER) IF(IER.NE.0) WRITE(*,*)' 500 OPEN UNIT ERROR IER=',IER READ(500,MODEL_DIMENSION) CLOSE(500,STATUS='KEEP') write(*,*) "NNXP=",NNXP(1)," NNYP=",NNYP(1)," NNZP=",NNZP(1) im=NNXP(1) jm=NNYP(1) lm=NNZP(1) lg=NNSOIL(1) ls=NNSNOW(1) !----------------------------------------- !----read cnsts file-------------------------------------------------- CLOSE(501) OPEN(UNIT=501,FILE='model_cnsts.name',FORM='FORMATTED',IOSTAT=IER) IF(IER.NE.0) WRITE(*,*)' 501 OPEN UNIT ERROR IER=',IER read(501,MODEL_CNSTS) !------------------------------------------ CLOSE(502) OPEN(UNIT=502,FILE='cycle_date',FORM='FORMATTED',IOSTAT=IER) IF(IER.NE.0)WRITE(*,*) ' 502 OPEN UNIT ERROR IER=',IER read(502,300) cycle_date 300 format(a14) !--- get fcst_length CLOSE(503) OPEN(UNIT=503,FILE='fcst_length.name',FORM='FORMATTED',IOSTAT=IER) IF(IER.NE.0) WRITE(*,*)' 503 OPEN UNIT ERROR IER=',IER READ(503,LENGTH) CLOSE(503,STATUS='KEEP') write(*,*) "fcst_length=",fcst_length," minutes" !--- read control variable list ------- CLOSE(103) OPEN(UNIT=103,FILE='cntrl_vrbl',FORM='FORMATTED',IOSTAT=IER) IF(IER.NE.0)WRITE(*,*)' 103 OPEN UNIT ERROR IER=',IER READ(103,*) cvar_max !-- read control variable parameters --------------- allocate(cvar_name(1:cvar_max)) allocate(cvar_ic(1:cvar_max)) allocate(cvar_param(1:cvar_max)) allocate(cvar_bias(1:cvar_max)) allocate(cvar_num_bias(1:cvar_max)) nullify(u_phi_ptr) nullify(u_bias_ptr) nullify(v_phi_ptr) nullify(v_bias_ptr) nullify(w_phi_ptr) nullify(w_bias_ptr) nullify(exnr_phi_ptr) nullify(exnr_bias_ptr) nullify(thetail_phi_ptr) nullify(thetail_bias_ptr) nullify(r_total_phi_ptr) nullify(r_total_bias_ptr) nullify(r_rain_phi_ptr) nullify(r_rain_bias_ptr) nullify(r_pice_phi_ptr) nullify(r_pice_bias_ptr) nullify(r_snow_phi_ptr) nullify(r_snow_bias_ptr) nullify(r_agreg_phi_ptr) nullify(r_agreg_bias_ptr) nullify(r_groupl_phi_ptr) nullify(r_groupl_bias_ptr) nullify(r_hail_phi_ptr) nullify(r_hail_bias_ptr) do i=1,cvar_max READ(103,*) cvar_name(i),cvar_ic(i),cvar_param(i),cvar_bias(i),cvar_num_bias(i) open_ic=open_ic.or.cvar_ic(i) open_param=open_param.or.cvar_param(i) open_bias=open_bias.or.cvar_bias(i) if(cvar_bias(i)) then if(cvar_name(i).eq.'u ') then allocate(u_phi(im,jm,lm)) allocate(u_bias(im,jm,lm)) u_phi(:,:,:)=0.0 u_bias(:,:,:)=0.0 u_phi_ptr => u_phi u_bias_ptr => u_bias else if(cvar_name(i).eq.'v ') then allocate(v_phi(im,jm,lm)) allocate(v_bias(im,jm,lm)) v_phi(:,:,:)=0.0 v_bias(:,:,:)=0.0 v_phi_ptr => v_phi v_bias_ptr => v_bias else if(cvar_name(i).eq.'w ') then allocate(w_phi(im,jm,lm)) allocate(w_bias(im,jm,lm)) w_phi(:,:,:)=0.0 w_bias(:,:,:)=0.0 w_phi_ptr => w_phi w_bias_ptr => w_bias else if(cvar_name(i).eq.'exnr ') then allocate(exnr_phi(im,jm,lm)) allocate(exnr_bias(im,jm,lm)) exnr_phi(:,:,:)=0.0 exnr_bias(:,:,:)=0.0 exnr_phi_ptr => exnr_phi exnr_bias_ptr => exnr_bias else if(cvar_name(i).eq.'thetail ') then allocate(thetail_phi(im,jm,lm)) allocate(thetail_bias(im,jm,lm)) thetail_phi(:,:,:)=0.0 thetail_bias(:,:,:)=0.0 thetail_phi_ptr => thetail_phi thetail_bias_ptr => thetail_bias else if(cvar_name(i).eq.'r_total ') then allocate(r_total_phi(im,jm,lm)) allocate(r_total_bias(im,jm,lm)) r_total_phi(:,:,:)=0.0 r_total_bias(:,:,:)=0.0 r_total_phi_ptr => r_total_phi r_total_bias_ptr => r_total_bias else if(cvar_name(i).eq.'r_rain ') then allocate(r_rain_phi(im,jm,lm)) allocate(r_rain_bias(im,jm,lm)) r_rain_phi(:,:,:)=0.0 r_rain_bias(:,:,:)=0.0 r_rain_phi_ptr => r_rain_phi r_rain_bias_ptr => r_rain_bias else if(cvar_name(i).eq.'r_pice ') then allocate(r_pice_phi(im,jm,lm)) allocate(r_pice_bias(im,jm,lm)) r_pice_phi(:,:,:)=0.0 r_pice_bias(:,:,:)=0.0 r_pice_phi_ptr => r_pice_phi r_pice_bias_ptr => r_pice_bias else if(cvar_name(i).eq.'r_snow ') then allocate(r_snow_phi(im,jm,lm)) allocate(r_snow_bias(im,jm,lm)) r_snow_phi(:,:,:)=0.0 r_snow_bias(:,:,:)=0.0 r_snow_phi_ptr => r_snow_phi r_snow_bias_ptr => r_snow_bias else if(cvar_name(i).eq.'r_agreg ') then allocate(r_agreg_phi(im,jm,lm)) allocate(r_agreg_bias(im,jm,lm)) r_agreg_phi(:,:,:)=0.0 r_agreg_bias(:,:,:)=0.0 r_agreg_phi_ptr => r_agreg_phi r_agreg_bias_ptr => r_agreg_bias else if(cvar_name(i).eq.'r_groupl ') then allocate(r_groupl_phi(im,jm,lm)) allocate(r_groupl_bias(im,jm,lm)) r_groupl_phi(:,:,:)=0.0 r_groupl_bias(:,:,:)=0.0 r_groupl_phi_ptr => r_groupl_phi r_groupl_bias_ptr => r_groupl_bias else if(cvar_name(i).eq.'r_hail ') then allocate(r_hail_phi(im,jm,lm)) allocate(r_hail_bias(im,jm,lm)) r_hail_phi(:,:,:)=0.0 r_hail_bias(:,:,:)=0.0 r_hail_phi_ptr => r_hail_phi r_hail_bias_ptr => r_hail_bias else if(cvar_name(i).eq.'r_cldliq ') then allocate(r_cldliq_phi(im,jm,lm)) allocate(r_cldliq_bias(im,jm,lm)) r_cldliq_phi(:,:,:)=0.0 r_cldliq_bias(:,:,:)=0.0 r_cldliq_phi_ptr => r_cldliq_phi r_cldliq_bias_ptr => r_cldliq_bias else write(*,*)"WARNING: NO model bias found for i=",i end if !!! if(cvar_name(i).eq.'u ') end if !!!! if(cvar_bias(i)) then end do !!!! do i=1,cvar_max if(open_bias) then num_bias=maxval(cvar_num_bias) else num_bias=0 end if deallocate(cvar_name) deallocate(cvar_ic) deallocate(cvar_param) deallocate(cvar_bias) deallocate(cvar_num_bias) CLOSE(103,STATUS='KEEP') !------------------------------------------------- end subroutine read_ensda_namelists !====================================================================== ! END OF READ_ENSDA_NAMELISTS !====================================================================== !====================================================================== ! BEGINNING OF READ_WRITE_ENSDA_NAMELISTS !====================================================================== subroutine read_write_ensda_namelists & (ifm,im,jm,lm,lg,ls,xparam) ! ********************************************************************** ! * PROGRAM: write_ensda_namelists ! * ! * PRGMMR: D. ZUPANSKI ORG: CIRA/CSU DATE: 2003-12-12 ! * ! * ABSTRACT: Read namelists and other constant input files for use in ensda ! ! ! * PROGRAM LOG: ! * ! * 12/12/2003 ..... D. ZUPANSKI, M. ZUPANSKI ! * 05/06/2004 ..... M. ZUPANSKI: Adjust to SWM_CSU model use ! * 06/18/2004 ..... D. ZUPANSKI: Adjust to RAMS model use !==================================== use ensda_variables implicit none integer :: ifm,im,jm,lm,lg,ls real :: xparam integer :: IER,i integer,dimension(1) :: & NNXP,NNYP,NNZP,NNSOIL,NNSNOW ! model dims written on model_dimension integer,dimension(:),allocatable :: & cvar_num_bias ! number of biases per cntrl vrbl character (len=9),dimension(:),allocatable :: & cvar_name ! cntrl vrbl name logical,dimension(:),allocatable :: & cvar_ic, &! init cond logical mask (per vrbl) cvar_param, &! empir param logical mask (per vrbl) cvar_bias ! model bias logical mask (per vrbl) !------------------------------ NAMELIST /MODEL_CNSTS/ xparam,aa !===================================== !-- read cycle_date ----------------------- CLOSE(502) OPEN(UNIT=502,FILE='cycle_date',FORM='FORMATTED',IOSTAT=IER) IF(IER.NE.0)WRITE(*,*) ' 502 OPEN UNIT ERROR IER=',IER read(502,300) cycle_date 300 format(a14) !--- write model dimensions NNXP(1)=im NNYP(1)=jm NNZP(1)=lm NNSOIL(1)=lg NNSNOW(1)=ls CLOSE(105) OPEN(UNIT=105,FILE='model_dimension',FORM='FORMATTED',IOSTAT=IER) IF(IER.NE.0) WRITE(*,*)' 105 OPEN UNIT ERROR IER=',IER WRITE(105,1001) NNXP(:) WRITE(105,1002) NNYP(:) WRITE(105,1003) NNZP(:) WRITE(105,1004) NNSOIL(:) WRITE(105,1005) NNSNOW(:) CLOSE(105,STATUS='KEEP') 1001 format(' NNXP = ',I8) 1002 format(' NNYP = ',I8) 1003 format(' NNZP = ',I8) 1004 format(' NNSOIL = ',I8) 1005 format(' NNSNOW = ',I8) !-- if nested, number of nests=n, it would assume NNXP(1:n) ---------- !1001 format(' NNXP = ',nI8) !1002 format(' NNYP = ',nI8) !1003 format(' NNZP = ',nI8) !1004 format(' NNSOIL = ',nI8) !1005 format(' NNSNOW = ',nI8) !-------------------------------------------------------------------- write(*,*) "NNXP=",NNXP(:)," NNYP=",NNYP(:)," NNZP=",NNZP(:) !----------------------------------------- !----read cnsts file-------------------------------------------------- CLOSE(501) OPEN(UNIT=501,FILE='model_cnsts.name',FORM='FORMATTED',IOSTAT=IER) IF(IER.NE.0) WRITE(*,*)' 501 OPEN UNIT ERROR IER=',IER read(501,MODEL_CNSTS) !------------------------------------------ !--- read control variable list ------- CLOSE(103) OPEN(UNIT=103,FILE='cntrl_vrbl',FORM='FORMATTED',IOSTAT=IER) IF(IER.NE.0)WRITE(*,*)' 103 OPEN UNIT ERROR IER=',IER READ(103,*) cvar_max !-- read control variable parameters --------------- allocate(cvar_name(1:cvar_max)) allocate(cvar_ic(1:cvar_max)) allocate(cvar_param(1:cvar_max)) allocate(cvar_bias(1:cvar_max)) allocate(cvar_num_bias(1:cvar_max)) nullify(u_phi_ptr) nullify(u_bias_ptr) nullify(v_phi_ptr) nullify(v_bias_ptr) nullify(w_phi_ptr) nullify(w_bias_ptr) nullify(exnr_phi_ptr) nullify(exnr_bias_ptr) nullify(thetail_phi_ptr) nullify(thetail_bias_ptr) nullify(r_total_phi_ptr) nullify(r_total_bias_ptr) nullify(r_rain_phi_ptr) nullify(r_rain_bias_ptr) nullify(r_pice_phi_ptr) nullify(r_pice_bias_ptr) nullify(r_snow_phi_ptr) nullify(r_snow_bias_ptr) nullify(r_agreg_phi_ptr) nullify(r_agreg_bias_ptr) nullify(r_groupl_phi_ptr) nullify(r_groupl_bias_ptr) nullify(r_hail_phi_ptr) nullify(r_hail_bias_ptr) do i=1,cvar_max READ(103,*) cvar_name(i),cvar_ic(i),cvar_param(i),cvar_bias(i),cvar_num_bias(i) open_ic=open_ic.or.cvar_ic(i) open_param=open_param.or.cvar_param(i) open_bias=open_bias.or.cvar_bias(i) if(cvar_bias(i)) then if(cvar_name(i).eq.'u ') then allocate(u_phi(im,jm,lm)) allocate(u_bias(im,jm,lm)) u_phi(:,:,:)=0.0 u_bias(:,:,:)=0.0 u_phi_ptr => u_phi u_bias_ptr => u_bias else if(cvar_name(i).eq.'v ') then allocate(v_phi(im,jm,lm)) allocate(v_bias(im,jm,lm)) v_phi(:,:,:)=0.0 v_bias(:,:,:)=0.0 v_phi_ptr => v_phi v_bias_ptr => v_bias else if(cvar_name(i).eq.'w ') then allocate(w_phi(im,jm,lm)) allocate(w_bias(im,jm,lm)) w_phi(:,:,:)=0.0 w_bias(:,:,:)=0.0 w_phi_ptr => w_phi w_bias_ptr => w_bias else if(cvar_name(i).eq.'exnr ') then allocate(exnr_phi(im,jm,lm)) allocate(exnr_bias(im,jm,lm)) exnr_phi(:,:,:)=0.0 exnr_bias(:,:,:)=0.0 exnr_phi_ptr => exnr_phi exnr_bias_ptr => exnr_bias else if(cvar_name(i).eq.'thetail ') then allocate(thetail_phi(im,jm,lm)) allocate(thetail_bias(im,jm,lm)) thetail_phi(:,:,:)=0.0 thetail_bias(:,:,:)=0.0 thetail_phi_ptr => thetail_phi thetail_bias_ptr => thetail_bias else if(cvar_name(i).eq.'r_total ') then allocate(r_total_phi(im,jm,lm)) allocate(r_total_bias(im,jm,lm)) r_total_phi(:,:,:)=0.0 r_total_bias(:,:,:)=0.0 r_total_phi_ptr => r_total_phi r_total_bias_ptr => r_total_bias else if(cvar_name(i).eq.'r_rain ') then allocate(r_rain_phi(im,jm,lm)) allocate(r_rain_bias(im,jm,lm)) r_rain_phi(:,:,:)=0.0 r_rain_bias(:,:,:)=0.0 r_rain_phi_ptr => r_rain_phi r_rain_bias_ptr => r_rain_bias else if(cvar_name(i).eq.'r_pice ') then allocate(r_pice_phi(im,jm,lm)) allocate(r_pice_bias(im,jm,lm)) r_pice_phi(:,:,:)=0.0 r_pice_bias(:,:,:)=0.0 r_pice_phi_ptr => r_pice_phi r_pice_bias_ptr => r_pice_bias else if(cvar_name(i).eq.'r_snow ') then allocate(r_snow_phi(im,jm,lm)) allocate(r_snow_bias(im,jm,lm)) r_snow_phi(:,:,:)=0.0 r_snow_bias(:,:,:)=0.0 r_snow_phi_ptr => r_snow_phi r_snow_bias_ptr => r_snow_bias else if(cvar_name(i).eq.'r_agreg ') then allocate(r_agreg_phi(im,jm,lm)) allocate(r_agreg_bias(im,jm,lm)) r_agreg_phi(:,:,:)=0.0 r_agreg_bias(:,:,:)=0.0 r_agreg_phi_ptr => r_agreg_phi r_agreg_bias_ptr => r_agreg_bias else if(cvar_name(i).eq.'r_groupl ') then allocate(r_groupl_phi(im,jm,lm)) allocate(r_groupl_bias(im,jm,lm)) r_groupl_phi(:,:,:)=0.0 r_groupl_bias(:,:,:)=0.0 r_groupl_phi_ptr => r_groupl_phi r_groupl_bias_ptr => r_groupl_bias else if(cvar_name(i).eq.'r_hail ') then allocate(r_hail_phi(im,jm,lm)) allocate(r_hail_bias(im,jm,lm)) r_hail_phi(:,:,:)=0.0 r_hail_bias(:,:,:)=0.0 r_hail_phi_ptr => r_hail_phi r_hail_bias_ptr => r_hail_bias else if(cvar_name(i).eq.'r_cldliq ') then allocate(r_cldliq_phi(im,jm,lm)) allocate(r_cldliq_bias(im,jm,lm)) r_cldliq_phi(:,:,:)=0.0 r_cldliq_bias(:,:,:)=0.0 r_cldliq_phi_ptr => r_cldliq_phi r_cldliq_bias_ptr => r_cldliq_bias else write(*,*)"WARNING: NO model bias found for i=",i end if !!! if(cvar_name(i).eq.'u ') end if !!!! if(cvar_bias(i)) then end do !!!! do i=1,cvar_max if(open_bias) then num_bias=maxval(cvar_num_bias) else num_bias=0 end if deallocate(cvar_name) deallocate(cvar_ic) deallocate(cvar_param) deallocate(cvar_bias) deallocate(cvar_num_bias) CLOSE(103,STATUS='KEEP') !------------------------------------------------- end subroutine read_write_ensda_namelists !====================================================================== ! END OF READ_WRITE_ENSDA_NAMELISTS !====================================================================== !====================================================================== ! BEGINNING OF READ_HISTORY_NONFORMAT !====================================================================== subroutine read_history_nonformat & (A,ifm,im,jm,lm,lg,ls, & iuc,ivc,iwc,ipc,ithp,irtp,irrp,irpp,irsp,irap,irgp, & irhp,ircp, & irv,itheta) ! ********************************************************************** ! * PROGRAM: read_history ! * ! * PRGMMR: D. ZUPANSKI ORG: CIRA/CSU DATE: 2003-12-12 ! * ! * ABSTRACT: Read history file (non-formatted) ! ! ! * PROGRAM LOG: ! * ! * 12/12/2003 ..... D. ZUPANSKI, M. ZUPANSKI ! * 05/06/2004 ..... M. ZUPANSKI: Adjust to SWM_CSU model use ! * 06/18/2004 ..... D. ZUPANSKI: Adjust to RAMS model use !==================================== use ensda_variables implicit none integer :: ifm,im,jm,lm,lg,ls integer :: iuc,ivc,iwc,ipc,ithp,irtp, & irrp,irpp,irsp,irap,irgp, & irhp,ircp, & irv,itheta real,dimension(*) :: A integer :: IER integer :: i integer :: histvar_max character (len=9),dimension(:),allocatable :: histvar_name !------------------------------------- !----define history file variables---------------------------------- histvar_max=6 i=0 ! allocate(histvar_name(10)) allocate(histvar_name(histvar_max)) i=i+1 histvar_name(i)='u ' i=i+1 histvar_name(i)='v ' i=i+1 histvar_name(i)='w ' i=i+1 histvar_name(i)='exnr ' i=i+1 histvar_name(i)='thetail ' i=i+1 histvar_name(i)='r_total ' ! i=i+1 ! histvar_name(i)='r_rain ' ! i=i+1 ! histvar_name(i)='r_pice ' ! i=i+1 ! histvar_name(i)='r_snow ' ! i=i+1 ! histvar_name(i)='r_agreg ' ! i=i+1 ! histvar_name(i)='r_groupl ' ! i=i+1 ! histvar_name(i)='r_hail ' ! i=i+1 ! histvar_name(i)='r_cldliq ' ! i=i+1 ! histvar_name(i)='r_vapor ' ! i=i+1 ! histvar_name(i)='theta ' !------------------------------------- !----read history file----------------------------------------------- CLOSE(400) OPEN(UNIT=400,FILE='model_history',FORM='UNFORMATTED',IOSTAT=IER) IF(IER.NE.0) WRITE(*,*)' 400 OPEN UNIT ERROR IER=',IER do i=1,histvar_max if(histvar_name(i).eq.'u ') then allocate(u(im,jm,lm)) read(400) u CALL CONVERT_inv (a(iuc),lm,im,jm,u) deallocate(u) elseif(histvar_name(i).eq.'v ') then allocate(v(im,jm,lm)) read(400) v CALL CONVERT_inv (a(ivc),lm,im,jm,v) deallocate(v) elseif(histvar_name(i).eq.'w ') then allocate(w(im,jm,lm)) read(400) w CALL CONVERT_inv (a(iwc),lm,im,jm,w) deallocate(w) elseif(histvar_name(i).eq.'exnr ') then allocate(exnr(im,jm,lm)) read(400) exnr CALL CONVERT_inv (a(ipc),lm,im,jm,exnr) deallocate(exnr) elseif(histvar_name(i).eq.'thetail ') then allocate(thetail(im,jm,lm)) read(400) thetail CALL CONVERT_inv (a(ithp),lm,im,jm,thetail) deallocate(thetail) elseif(histvar_name(i).eq.'r_total ') then allocate(r_total(im,jm,lm)) read(400) r_total CALL CONVERT_inv (a(irtp),lm,im,jm,r_total) deallocate(r_total) elseif(histvar_name(i).eq.'r_rain ') then allocate(r_rain(im,jm,lm)) read(400) r_rain CALL CONVERT_inv (a(irrp),lm,im,jm,r_rain) deallocate(r_rain) elseif(histvar_name(i).eq.'r_pice ') then allocate(r_pice(im,jm,lm)) read(400) r_pice CALL CONVERT_inv (a(irpp),lm,im,jm,r_pice) deallocate(r_pice) elseif(histvar_name(i).eq.'r_snow ') then allocate(r_snow(im,jm,lm)) read(400) r_snow CALL CONVERT_inv (a(irsp),lm,im,jm,r_snow) deallocate(r_snow) elseif(histvar_name(i).eq.'r_agreg ') then allocate(r_agreg(im,jm,lm)) read(400) r_agreg CALL CONVERT_inv (a(irap),lm,im,jm,r_agreg) deallocate(r_agreg) elseif(histvar_name(i).eq.'r_groupl ') then allocate(r_groupl(im,jm,lm)) read(400) r_groupl CALL CONVERT_inv (a(irgp),lm,im,jm,r_groupl) deallocate(r_groupl) elseif(histvar_name(i).eq.'r_hail ') then allocate(r_hail(im,jm,lm)) read(400) r_hail CALL CONVERT_inv (a(irhp),lm,im,jm,r_hail) deallocate(r_hail) elseif(histvar_name(i).eq.'r_cldliq ') then allocate(r_cldliq(im,jm,lm)) read(400) r_cldliq CALL CONVERT_inv (a(ircp),lm,im,jm,r_cldliq) deallocate(r_cldliq) elseif(histvar_name(i).eq.'r_vapor ') then allocate(r_vapor(im,jm,lm)) read(400) r_vapor CALL CONVERT_inv (a(irv),lm,im,jm,r_vapor) deallocate(r_vapor) elseif(histvar_name(i).eq.'theta ') then allocate(theta(im,jm,lm)) read(400) theta CALL CONVERT_inv (a(itheta),lm,im,jm,theta) deallocate(theta) else write(*,*) "PROBLEM: NO history file variables were found" end if !!!if(histvar_name(i).eq.'u ') end do !!!! do i=1,histvar_max deallocate(histvar_name) CLOSE(400,STATUS='KEEP') !------------------------------------- end subroutine read_history_nonformat !====================================================================== ! END OF READ_HISTORY_NONFORMAT !====================================================================== !====================================================================== ! BEGINNING OF WRITE_HISTORY_NONFORMAT !====================================================================== subroutine write_history_nonformat & (A,ifm,im,jm,lm,lg,ls, & iuc,ivc,iwc,ipc,ithp,irtp,irrp,irpp,irsp,irap,irgp, & irhp,ircp, & irv,itheta) ! ********************************************************************** ! * PROGRAM: write_history ! * ! * PRGMMR: D. ZUPANSKI ORG: CIRA/CSU DATE: 2003-12-12 ! * ! * ABSTRACT: Read history file (non-formatted) ! ! ! * PROGRAM LOG: ! * ! * 12/12/2003 ..... D. ZUPANSKI, M. ZUPANSKI ! * 05/06/2004 ..... M. ZUPANSKI: Adjust to SWM_CSU model use ! * 06/21/2004 ..... M. ZUPANSKI: Adjust to RAMS model use !==================================== use ensda_variables implicit none integer :: ifm,im,jm,lm,lg,ls integer :: iuc,ivc,iwc,ipc,ithp,irtp, & irrp,irpp,irsp,irap,irgp, & irhp,ircp, & irv,itheta real,dimension(*) :: A integer :: IER integer :: i integer :: histvar_max character (len=9),dimension(:),allocatable :: histvar_name !------------------------------------- !----define history file variables---------------------------------- histvar_max=6 i=0 ! allocate(histvar_name(10)) allocate(histvar_name(histvar_max)) i=i+1 histvar_name(i)='u ' i=i+1 histvar_name(i)='v ' i=i+1 histvar_name(i)='w ' i=i+1 histvar_name(i)='exnr ' i=i+1 histvar_name(i)='thetail ' i=i+1 histvar_name(i)='r_total ' ! i=i+1 ! histvar_name(i)='r_rain ' ! i=i+1 ! histvar_name(i)='r_pice ' ! i=i+1 ! histvar_name(i)='r_snow ' ! i=i+1 ! histvar_name(i)='r_agreg ' ! i=i+1 ! histvar_name(i)='r_groupl ' ! i=i+1 ! histvar_name(i)='r_hail ' ! i=i+1 ! histvar_name(i)='r_cldliq ' ! i=i+1 ! histvar_name(i)='r_vapor ' ! i=i+1 ! histvar_name(i)='theta ' !------------------------------------- !----write history file----------------------------------------------- CLOSE(400) OPEN(UNIT=400,FILE='model_history',FORM='UNFORMATTED',IOSTAT=IER) IF(IER.NE.0) WRITE(*,*)' 400 OPEN UNIT ERROR IER=',IER do i=1,histvar_max if(histvar_name(i).eq.'u ') then allocate(u(im,jm,lm)) CALL CONVERT (a(iuc),lm,im,jm,u) write(400) u deallocate(u) elseif(histvar_name(i).eq.'v ') then allocate(v(im,jm,lm)) CALL CONVERT (a(ivc),lm,im,jm,v) write(400) v deallocate(v) elseif(histvar_name(i).eq.'w ') then allocate(w(im,jm,lm)) CALL CONVERT (a(iwc),lm,im,jm,w) write(400) w deallocate(w) elseif(histvar_name(i).eq.'exnr ') then allocate(exnr(im,jm,lm)) CALL CONVERT (a(ipc),lm,im,jm,exnr) write(400) exnr deallocate(exnr) elseif(histvar_name(i).eq.'thetail ') then allocate(thetail(im,jm,lm)) CALL CONVERT (a(ithp),lm,im,jm,thetail) write(400) thetail deallocate(thetail) elseif(histvar_name(i).eq.'r_total ') then allocate(r_total(im,jm,lm)) CALL CONVERT (a(irtp),lm,im,jm,r_total) write(400) r_total deallocate(r_total) elseif(histvar_name(i).eq.'r_rain ') then allocate(r_rain(im,jm,lm)) CALL CONVERT (a(irrp),lm,im,jm,r_rain) write(400) r_rain deallocate(r_rain) elseif(histvar_name(i).eq.'r_pice ') then allocate(r_pice(im,jm,lm)) CALL CONVERT (a(irpp),lm,im,jm,r_pice) write(400) r_pice deallocate(r_pice) elseif(histvar_name(i).eq.'r_snow ') then allocate(r_snow(im,jm,lm)) CALL CONVERT (a(irsp),lm,im,jm,r_snow) write(400) r_snow deallocate(r_snow) elseif(histvar_name(i).eq.'r_agreg ') then allocate(r_agreg(im,jm,lm)) CALL CONVERT (a(irap),lm,im,jm,r_agreg) write(400) r_agreg deallocate(r_agreg) elseif(histvar_name(i).eq.'r_groupl ') then allocate(r_groupl(im,jm,lm)) CALL CONVERT (a(irgp),lm,im,lm,r_groupl) write(400) r_groupl deallocate(r_groupl) elseif(histvar_name(i).eq.'r_hail ') then allocate(r_hail(im,jm,lm)) CALL CONVERT (a(irhp),lm,im,jm,r_hail) write(400) r_hail deallocate(r_hail) elseif(histvar_name(i).eq.'r_cldliq ') then allocate(r_cldliq(im,jm,lm)) CALL CONVERT (a(ircp),lm,im,jm,r_cldliq) write(400) r_cldliq deallocate(r_cldliq) elseif(histvar_name(i).eq.'r_vapor ') then allocate(r_vapor(im,jm,lm)) CALL CONVERT (a(irv),lm,im,jm,r_vapor) write(400) r_vapor deallocate(r_vapor) elseif(histvar_name(i).eq.'theta ') then allocate(theta(im,jm,lm)) CALL CONVERT (a(itheta),lm,im,jm,theta) write(400) theta deallocate(theta) else write(*,*) "PROBLEM: NO history file variables were found" end if !!! if(histvar_name(i).eq.'u ') end do !!!! do i=1,histvar_max CLOSE(400,STATUS='KEEP') !------------------------------------- end subroutine write_history_nonformat !====================================================================== ! END OF WRITE_HISTORY_NONFORMAT !====================================================================== !====================================================================== ! BEGINNING OF WRITE_HISTORY_FORMAT !====================================================================== subroutine write_history_format & (A,n,dt_sec,ifm,im,jm,lm,lg,ls, & iuc,ivc,iwc,ipc,ithp,irtp,irrp,irpp,irsp,irap,irgp, & irhp,ircp, & irv,itheta) ! ********************************************************************** ! * PROGRAM: write_history_format ! * ! * PRGMMR: D. ZUPANSKI ORG: CIRA/CSU DATE: 2003-12-12 ! * ! * ABSTRACT: Write history file (formatted) ! ! ! * PROGRAM LOG: ! * ! * 12/12/2003 ..... D. ZUPANSKI, M. ZUPANSKI ! * 05/06/2004 ..... M. ZUPANSKI: Adjust to SWM_CSU model use ! * 06/21/2004 ..... D. ZUPANSKI: Adjust to RAMS model use !==================================== use ensda_variables implicit none integer :: n real :: dt_sec integer :: ifm,im,jm,lm,lg,ls integer :: iuc,ivc,iwc,ipc,ithp,irtp, & irrp,irpp,irsp,irap,irgp, & irhp,ircp, & irv,itheta real,dimension(*) :: A integer,parameter :: iparm=300 ! PARM file unit integer,parameter :: ihist=401 ! formatted history file integer :: IER,i,j,l,ii character(len=40) :: filename character(len=14) :: rdate_out character(len=14) :: cycle_start_date integer :: cycle_interval,N_cycles character(len=13) :: jdate,jdate_fg integer :: year,jday,hour integer :: year_fg,jday_fg,hour_fg integer :: idiff,ndiff ! ! DECLARE NAMELISTS ! NAMELIST /CYCLE/ cycle_start_date,cycle_interval,N_cycles !=========================================================== integer :: histvar_max character (len=9),dimension(:),allocatable :: histvar_name !------------------------------------- 100 format(E20.10) 110 format(3i7) 300 format(a9) !----write history file at the end of forecast----------------------- CLOSE(iparm) OPEN(UNIT=iparm,FILE='cycle.parm',FORM='FORMATTED',IOSTAT=IER) IF(IER.NE.0)WRITE(*,*) iparm,' OPEN UNIT ERROR IER=',IER READ(iparm,CYCLE) CLOSE(iparm,status='KEEP') !----- idiff=(sec), cycle_interval=(min) idiff=cycle_interval*60 ndiff=int(n*dt_sec+0.5) if(MOD(ndiff,idiff).eq.0) then !----define history file variables---------------------------------- histvar_max=6 ii=0 allocate(histvar_name(histvar_max)) ii=ii+1 histvar_name(ii)='u ' ii=ii+1 histvar_name(ii)='v ' ii=ii+1 histvar_name(ii)='w ' ii=ii+1 histvar_name(ii)='exnr ' ii=ii+1 histvar_name(ii)='thetail ' ii=ii+1 histvar_name(ii)='r_total ' ! ii=ii+1 ! histvar_name(ii)='r_rain ' ! ii=ii+1 ! histvar_name(ii)='r_pice ' ! ii=ii+1 ! histvar_name(ii)='r_snow ' ! ii=ii+1 ! histvar_name(ii)='r_agreg ' ! ii=ii+1 ! histvar_name(ii)='r_groupl ' ! ii=ii+1 ! histvar_name(ii)='r_hail ' ! ii=ii+1 ! histvar_name(ii)='r_cldliq ' ! ii=ii+1 ! histvar_name(ii)='r_vapor ' ! ii=ii+1 ! histvar_name(ii)='theta ' !------------------------------------- call rdate_to_jdate (cycle_date,jdate,year,jday,hour) call add_to_jdate(year,jday,hour,ndiff,year_fg, & jday_fg,hour_fg) call jdate_make_big (year_fg,jday_fg,hour_fg,jdate_fg) call jdate_to_rdate (jdate_fg,rdate_out) write(filename,1001) rdate_out 1001 format('model_history.',a14) !------------------------------------- CLOSE(ihist) OPEN(UNIT=ihist,FILE=filename,FORM='UNFORMATTED',IOSTAT=IER) IF(IER.NE.0) WRITE(*,*) ihist,' OPEN UNIT ERROR IER=',IER ! write(ihist,110) im,jm,lm write(ihist) im,jm,lm do ii=1,histvar_max if(histvar_name(ii).eq.'u ') then allocate(u(im,jm,lm)) CALL CONVERT (a(iuc),lm,im,jm,u) ! write(ihist,300) histvar_name(ii) write(ihist) histvar_name(ii) ! do l=1,lm ! do j=1,jm ! do i=1,im ! write(ihist,100) u(i,j,l) ! end do ! end do ! end do write(ihist) u deallocate(u) elseif(histvar_name(ii).eq.'v ') then allocate(v(im,jm,lm)) CALL CONVERT (a(ivc),lm,im,jm,v) write(ihist) histvar_name(ii) write(ihist) v deallocate(v) elseif(histvar_name(ii).eq.'w ') then allocate(w(im,jm,lm)) CALL CONVERT (a(iwc),lm,im,jm,w) write(ihist) histvar_name(ii) write(ihist) w deallocate(w) elseif(histvar_name(ii).eq.'exnr ') then allocate(exnr(im,jm,lm)) CALL CONVERT (a(ipc),lm,im,jm,exnr) write(ihist) histvar_name(ii) write(ihist) exnr deallocate(exnr) elseif(histvar_name(ii).eq.'thetail ') then allocate(thetail(im,jm,lm)) CALL CONVERT (a(ithp),lm,im,jm,thetail) write(ihist) histvar_name(ii) write(ihist) thetail deallocate(thetail) elseif(histvar_name(ii).eq.'r_total ') then allocate(r_total(im,jm,lm)) CALL CONVERT (a(irtp),lm,im,jm,r_total) write(ihist) histvar_name(ii) write(ihist) r_total deallocate(r_total) elseif(histvar_name(ii).eq.'r_rain ') then allocate(r_rain(im,jm,lm)) CALL CONVERT (a(irrp),lm,im,jm,r_rain) write(ihist) histvar_name(ii) write(ihist) r_rain deallocate(r_rain) elseif(histvar_name(ii).eq.'r_pice ') then allocate(r_pice(im,jm,lm)) CALL CONVERT (a(irpp),lm,im,jm,r_pice) write(ihist) histvar_name(ii) write(ihist) r_pice deallocate(r_pice) elseif(histvar_name(ii).eq.'r_snow ') then allocate(r_snow(im,jm,lm)) CALL CONVERT (a(irsp),lm,im,jm,r_snow) write(ihist) histvar_name(ii) write(ihist) r_snow deallocate(r_snow) elseif(histvar_name(ii).eq.'r_agreg ') then allocate(r_agreg(im,jm,lm)) CALL CONVERT (a(irap),lm,im,jm,r_agreg) write(ihist) histvar_name(ii) write(ihist) r_agreg deallocate(r_agreg) elseif(histvar_name(ii).eq.'r_groupl ') then allocate(r_groupl(im,jm,lm)) CALL CONVERT (a(irgp),lm,im,jm,r_groupl) write(ihist) histvar_name(ii) write(ihist) r_groupl deallocate(r_groupl) elseif(histvar_name(ii).eq.'r_hail ') then allocate(r_hail(im,jm,lm)) CALL CONVERT (a(irhp),lm,im,jm,r_hail) write(ihist) histvar_name(ii) write(ihist) r_hail deallocate(r_hail) elseif(histvar_name(ii).eq.'r_cldliq ') then allocate(r_cldliq(im,jm,lm)) CALL CONVERT (a(ircp),lm,im,jm,r_cldliq) write(ihist) histvar_name(ii) write(ihist) r_cldliq deallocate(r_cldliq) elseif(histvar_name(ii).eq.'r_vapor ') then allocate(r_vapor(im,jm,lm)) CALL CONVERT (a(irv),lm,im,jm,r_vapor) write(ihist) histvar_name(ii) write(ihist) r_vapor deallocate(r_vapor) elseif(histvar_name(ii).eq.'theta ') then allocate(theta(im,jm,lm)) CALL CONVERT (a(itheta),lm,im,jm,theta) write(ihist) histvar_name(ii) write(ihist) theta deallocate(theta) else write(*,*) "PROBLEM: NO history file variables were found" end if !!! if(histvar_name(ii).eq.'u ') end do !!!! do ii=1,histvar_max CLOSE(ihist,STATUS='KEEP') end if !!!! if(MOD(ndiff,idiff).eq.0) end subroutine write_history_format !====================================================================== ! END OF WRITE_HISTORY_FORMAT !====================================================================== !====================================================================== ! BEGINNING OF WRITE_FG !====================================================================== subroutine write_fg & (A,n,dt_sec,ifm,im,jm,lm,lg,ls, & iuc,ivc,iwc,ipc,ithp,irtp,irrp,irpp,irsp,irap,irgp, & irhp,ircp, & irv,itheta) ! ********************************************************************** ! ! ROUTINE: write_fg: write files with first guess forecast ! used in ensda ! PRGMMR: D. ZUPANSKI ORG: CIRA/CSU DATE: 2003-09-30 ! ! ! REVISION HISTORY: ! ! 09/30/2003 ..... D. ZUPANSKI ! !----------------------------------------------------------------------- use ensda_variables implicit NONE integer :: n real :: dt_sec integer :: ifm,im,jm,lm,lg,ls integer :: iuc,ivc,iwc,ipc,ithp,irtp, & irrp,irpp,irsp,irap,irgp, & irhp,ircp, & irv,itheta real,dimension(*) :: A integer,parameter :: i_parm=201 ! PARM file unit integer,parameter :: i_obstype=202 ! OBSTYPE file unit integer,parameter :: i_jdate=203 ! jdate_ file unit integer,parameter :: i_fguess=204 ! first guess file unit integer :: fgvar_max,IER,i character(len=40) :: file_fguess,file_obstype,file_jdate character(len=14) :: rdate_out character(len=13) :: jdate,jdate_fg,jdate_obs character(len=9), dimension(:),allocatable :: fgvar_name character (len=6) :: OBSTYPE character (len=3) :: OBSFLAG integer :: kk integer :: year,jday,hour integer :: year_fg,jday_fg,hour_fg integer :: year_obs,jday_obs,hour_obs integer :: iobs,iobsmax,delobs,idiff,idiff_obs integer, dimension(:),allocatable :: kk_start,kk_end logical :: output ! ! DECLARE NAMELISTS ! NAMELIST /OBSPARM/ OBSTYPE,delobs,OBSFLAG !=========================================================== CLOSE(i_parm) OPEN(UNIT=i_parm,FILE='kk_index.parm',FORM='FORMATTED',IOSTAT=IER) IF(IER.NE.0)WRITE(*,*) i_parm,' OPEN UNIT ERROR IER=',IER read(i_parm,*) iobsmax allocate(kk_start(1:iobsmax)) allocate(kk_end(1:iobsmax)) do i=1,iobsmax read(i_parm,*) kk_start(i),kk_end(i) end do CLOSE(i_parm,status='keep') output=.FALSE. do iobs=1,iobsmax write(file_obstype,1002) iobs 1002 format('OBSTYPE_',i2.2,'.name') CLOSE(i_obstype) OPEN(UNIT=i_obstype,FILE=file_obstype,FORM='FORMATTED',IOSTAT=IER) IF(IER.NE.0) WRITE(*,*) i_obstype,' OPEN UNIT ERROR IER=',IER read(i_obstype,OBSPARM) CLOSE(i_obstype,status='KEEP') if(OBSFLAG.eq.'YES') then write(file_fguess,1004) OBSTYPE 1004 format('first_guess_',a6) CLOSE(105) OPEN(105,FILE=file_fguess,FORM='FORMATTED',IOSTAT=IER) IF(IER.NE.0)WRITE(*,*)' 105 OPEN UNIT ERROR IER=',IER READ(105,*) fgvar_max allocate(fgvar_name(1:fgvar_max)) do i=1,fgvar_max READ(105,*) fgvar_name(i) end do CLOSE(105,STATUS='KEEP') !----- define appropriate jdate call rdate_to_jdate (cycle_date,jdate,year,jday,hour) !---- Forecast starts from time defined by cycle_date idiff=int(n*dt_sec-dt_sec/2.+0.5) call add_to_jdate(year,jday,hour,idiff,year_fg, & jday_fg,hour_fg) do kk=kk_start(iobs),kk_end(iobs) !----- idiff=(sec), delobs=(min) idiff=kk*delobs*60 !----- ASSUMPTION: observations are defined at equal time intervals (in min) !----- starting from time defined by cycle_date call add_to_jdate(year,jday,hour,idiff,year_obs, & jday_obs,hour_obs) call diff_date1_date2(year_obs,jday_obs,hour_obs, & year_fg,jday_fg,hour_fg,idiff_obs) if(idiff_obs.ge.0.and.idiff_obs.lt.int(dt_sec)) then !----- define output jdate_fg call jdate_make_big (year_obs,jday_obs,hour_obs,jdate_fg) call jdate_to_rdate (jdate_fg,rdate_out) write(file_jdate,1003) OBSTYPE,rdate_out 1003 format('jdate_',a6,'_',a14) CLOSE(i_jdate) OPEN(UNIT=i_jdate,FILE=file_jdate,FORM='FORMATTED',IOSTAT=IER) IF(IER.NE.0) WRITE(*,*) i_jdate,' OPEN UNIT ERROR IER=',IER read(i_jdate,105,end=107) jdate_obs CLOSE(i_jdate,status='keep') 105 format(a13) if(jdate_fg.eq.jdate_obs) then !------- START model specific part --------- write(file_fguess,1001) OBSTYPE,rdate_out 1001 format('fguess_',a6,'.',a14) write(*,*) " file_fguess =",file_fguess CLOSE(i_fguess) OPEN(UNIT=i_fguess,FILE=file_fguess,FORM='UNFORMATTED',IOSTAT=IER) IF(IER.NE.0) WRITE(*,*) i_fguess,' OPEN UNIT ERROR IER=',IER do i=1,fgvar_max if(fgvar_name(i).eq.'u ') then allocate(u(im,jm,lm)) CALL CONVERT (a(iuc),lm,im,jm,u) write(i_fguess) fgvar_name(i) write(i_fguess) u deallocate(u) else if(fgvar_name(i).eq.'v ') then allocate(v(im,jm,lm)) CALL CONVERT (a(ivc),lm,im,jm,v) write(i_fguess) fgvar_name(i) write(i_fguess) v deallocate(v) else if(fgvar_name(i).eq.'w ') then allocate(w(im,jm,lm)) CALL CONVERT (a(iwc),lm,im,jm,w) write(i_fguess) fgvar_name(i) write(i_fguess) w deallocate(w) elseif(fgvar_name(i).eq.'exnr ') then allocate(exnr(im,jm,lm)) CALL CONVERT (a(ipc),lm,im,jm,exnr) write(i_fguess) fgvar_name(i) write(i_fguess) exnr deallocate(exnr) elseif(fgvar_name(i).eq.'thetail ') then allocate(thetail(im,jm,lm)) CALL CONVERT (a(ithp),lm,im,jm,thetail) write(i_fguess) fgvar_name(i) write(i_fguess) thetail deallocate(thetail) elseif(fgvar_name(i).eq.'r_total ') then allocate(r_total(im,jm,lm)) CALL CONVERT (a(irtp),lm,im,jm,r_total) write(i_fguess) fgvar_name(i) write(i_fguess) r_total deallocate(r_total) elseif(fgvar_name(i).eq.'r_rain ') then allocate(r_rain(im,jm,lm)) CALL CONVERT (a(irrp),lm,im,jm,r_rain) write(i_fguess) fgvar_name(i) write(i_fguess) r_rain deallocate(r_rain) elseif(fgvar_name(i).eq.'r_pice ') then allocate(r_pice(im,jm,lm)) CALL CONVERT (a(irpp),lm,im,jm,r_pice) write(i_fguess) fgvar_name(i) write(i_fguess) r_pice deallocate(r_pice) elseif(fgvar_name(i).eq.'r_snow ') then allocate(r_snow(im,jm,lm)) CALL CONVERT (a(irsp),lm,im,jm,r_snow) write(i_fguess) fgvar_name(i) write(i_fguess) r_snow deallocate(r_snow) elseif(fgvar_name(i).eq.'r_agreg ') then allocate(r_agreg(im,jm,lm)) CALL CONVERT (a(irap),lm,im,jm,r_agreg) write(i_fguess) fgvar_name(i) write(i_fguess) r_agreg deallocate(r_agreg) elseif(fgvar_name(i).eq.'r_groupl ') then allocate(r_groupl(im,jm,lm)) CALL CONVERT (a(irgp),lm,im,lm,r_groupl) write(i_fguess) fgvar_name(i) write(i_fguess) r_groupl deallocate(r_groupl) elseif(fgvar_name(i).eq.'r_hail ') then allocate(r_hail(im,jm,lm)) CALL CONVERT (a(irhp),lm,im,jm,r_hail) write(i_fguess) fgvar_name(i) write(i_fguess) r_hail deallocate(r_hail) elseif(fgvar_name(i).eq.'r_cldliq ') then allocate(r_cldliq(im,jm,lm)) CALL CONVERT (a(ircp),lm,im,jm,r_cldliq) write(i_fguess) fgvar_name(i) write(i_fguess) r_cldliq deallocate(r_cldliq) elseif(fgvar_name(i).eq.'r_vapor ') then allocate(r_vapor(im,jm,lm)) CALL CONVERT (a(irv),lm,im,jm,r_vapor) write(i_fguess) fgvar_name(i) write(i_fguess) r_vapor deallocate(r_vapor) elseif(fgvar_name(i).eq.'theta ') then allocate(theta(im,jm,lm)) CALL CONVERT (a(itheta),lm,im,jm,theta) write(i_fguess) fgvar_name(i) write(i_fguess) theta deallocate(theta) else write(*,*) "PROBLEM: NO first guess variables were found" end if !!! if(fgvar_name(i).eq.'u ') end do !!!! do i=1,fgvar_max CLOSE(i_fguess,status='KEEP') else write(*,*) "PROBLEM in write_fg, jdate_fg=",jdate_fg, & "jdate_obs=",jdate_obs !------- END model specific part --------- endif !!!! if(jdate_fg.eq.jdate_obs) 107 continue kk_start(iobs)=kk+1 output=.TRUE. exit endif !! if(idiff_obs.ge.0.and.idiff_obs.lt.dt_sec) then if(idiff_obs.gt.0) exit end do !!! kk=kk_start,kobs endif !!! if(OBSFLAG.eq.'YES') then end do !!! iobs=1,iobsmax if(output) then CLOSE(i_parm) OPEN(UNIT=i_parm,FILE='kk_index.parm',FORM='FORMATTED',IOSTAT=IER) IF(IER.NE.0)WRITE(*,*) i_parm,' OPEN UNIT ERROR IER=',IER write(i_parm,*) iobsmax do i=1,iobsmax write(i_parm,*) kk_start(i),kk_end(i) end do CLOSE(i_parm,status='keep') end if end subroutine write_fg !====================================================================== ! END OF WRITE_FG !====================================================================== !====================================================================== ! BEGINNING OF BIAS_TIME !====================================================================== subroutine bias_time & (A,n,ifm,im,jm,lm,lg,ls, & iuc,ivc,iwc,ipc,ithp,irtp,irrp,irpp,irsp,irap,irgp, & irhp,ircp, & irv,itheta) ! ********************************************************************** ! ! PROGRAM: bias_time update model bias in current time step ! PRGMMR: M. ZUPANSKI ORG: CIRA/CSU DATE: 2004-05-07 ! ! ! REVISION HISTORY: ! ! 05/07/2004 ..... M. ZUPANSKI ! 06/21/2004 ..... D. ZUPANSKI: RAMS model ! !----------------------------------------------------------------------- use ensda_variables implicit NONE integer :: ifm,im,jm,lm,lg,ls integer :: iuc,ivc,iwc,ipc,ithp,irtp, & irrp,irpp,irsp,irap,irgp, & irhp,ircp, & irv,itheta real,dimension(*) :: A integer :: i,j,k integer :: n !=========================================================== if(open_bias) then if((n.ne.ntime).and.(mod(n,nerr).eq.0.or.n.eq.1)) then nbias=nbias+1 call read_model_bias (ifm,im,jm,lm,lg,ls) endif !-- Markov process variable (systematic error) if(associated(u_phi_ptr)) then allocate(u(im,jm,lm)) CALL CONVERT (a(iuc),lm,im,jm,u) do k=1,lm do j=1,jm do i=1,im u_phi_ptr(i,j,k)=aa*u_phi_ptr(i,j,k)+(1.-aa)*u_bias_ptr(i,j,k) u(i,j,k)=u(i,j,k)+u_phi_ptr(i,j,k) end do end do end do CALL CONVERT_inv (a(iuc),lm,im,jm,u) deallocate(u) else if(associated(v_phi_ptr)) then allocate(v(im,jm,lm)) CALL CONVERT (a(ivc),lm,im,jm,v) do k=1,lm do j=1,jm do i=1,im v_phi_ptr(i,j,k)=aa*v_phi_ptr(i,j,k)+(1.-aa)*v_bias_ptr(i,j,k) v(i,j,k)=v(i,j,k)+v_phi_ptr(i,j,k) end do end do end do CALL CONVERT_inv (a(ivc),lm,im,jm,v) deallocate(v) else if(associated(w_phi_ptr)) then allocate(w(im,jm,lm)) CALL CONVERT (a(iwc),lm,im,jm,w) do k=1,lm do j=1,jm do i=1,im w_phi_ptr(i,j,k)=aa*w_phi_ptr(i,j,k)+(1.-aa)*w_bias_ptr(i,j,k) w(i,j,k)=w(i,j,k)+w_phi_ptr(i,j,k) end do end do end do CALL CONVERT_inv (a(iwc),lm,im,jm,w) deallocate(w) else if(associated(exnr_phi_ptr)) then allocate(exnr(im,jm,lm)) CALL CONVERT (a(ipc),lm,im,jm,exnr) do k=1,lm do j=1,jm do i=1,im exnr_phi_ptr(i,j,k)=aa*exnr_phi_ptr(i,j,k)+(1.-aa)*exnr_bias_ptr(i,j,k) exnr(i,j,k)=exnr(i,j,k)+exnr_phi_ptr(i,j,k) end do end do end do CALL CONVERT_inv (a(ipc),lm,im,jm,exnr) deallocate(exnr) else if(associated(thetail_phi_ptr)) then allocate(thetail(im,jm,lm)) CALL CONVERT (a(ithp),lm,im,jm,thetail) do k=1,lm do j=1,jm do i=1,im thetail_phi_ptr(i,j,k)=aa*thetail_phi_ptr(i,j,k)+(1.-aa)*thetail_bias_ptr(i,j,k) thetail(i,j,k)=thetail(i,j,k)+thetail_phi_ptr(i,j,k) end do end do end do CALL CONVERT_inv (a(ithp),lm,im,jm,thetail) deallocate(thetail) else if(associated(r_total_phi_ptr)) then allocate(r_total(im,jm,lm)) CALL CONVERT (a(irtp),lm,im,jm,r_total) do k=1,lm do j=1,jm do i=1,im r_total_phi_ptr(i,j,k)=aa*r_total_phi_ptr(i,j,k)+(1.-aa)*r_total_bias_ptr(i,j,k) r_total(i,j,k)=r_total(i,j,k)+r_total_phi_ptr(i,j,k) end do end do end do CALL CONVERT_inv (a(irtp),lm,im,jm,r_total) deallocate(r_total) else if(associated(r_rain_phi_ptr)) then allocate(r_rain(im,jm,lm)) CALL CONVERT (a(irrp),lm,im,jm,r_rain) do k=1,lm do j=1,jm do i=1,im r_rain_phi_ptr(i,j,k)=aa*r_rain_phi_ptr(i,j,k)+(1.-aa)*r_rain_bias_ptr(i,j,k) r_rain(i,j,k)=r_rain(i,j,k)+r_rain_phi_ptr(i,j,k) end do end do end do CALL CONVERT_inv (a(irrp),lm,im,jm,r_rain) deallocate(r_rain) else if(associated(r_pice_phi_ptr)) then allocate(r_pice(im,jm,lm)) CALL CONVERT (a(irpp),lm,im,jm,r_pice) do k=1,lm do j=1,jm do i=1,im r_pice_phi_ptr(i,j,k)=aa*r_pice_phi_ptr(i,j,k)+(1.-aa)*r_pice_bias_ptr(i,j,k) r_pice(i,j,k)=r_pice(i,j,k)+r_pice_phi_ptr(i,j,k) end do end do end do CALL CONVERT_inv (a(irpp),lm,im,jm,r_pice) deallocate(r_pice) else if(associated(r_snow_phi_ptr)) then allocate(r_snow(im,jm,lm)) CALL CONVERT (a(irsp),lm,im,jm,r_snow) do k=1,lm do j=1,jm do i=1,im r_snow_phi_ptr(i,j,k)=aa*r_snow_phi_ptr(i,j,k)+(1.-aa)*r_snow_bias_ptr(i,j,k) r_snow(i,j,k)=r_snow(i,j,k)+r_snow_phi_ptr(i,j,k) end do end do end do CALL CONVERT_inv (a(irsp),lm,im,jm,r_snow) deallocate(r_snow) else if(associated(r_agreg_phi_ptr)) then allocate(r_agreg(im,jm,lm)) CALL CONVERT (a(irap),lm,im,jm,r_agreg) do k=1,lm do j=1,jm do i=1,im r_agreg_phi_ptr(i,j,k)=aa*r_agreg_phi_ptr(i,j,k)+(1.-aa)*r_agreg_bias_ptr(i,j,k) r_agreg(i,j,k)=r_agreg(i,j,k)+r_agreg_phi_ptr(i,j,k) end do end do end do CALL CONVERT_inv (a(irap),lm,im,jm,r_agreg) deallocate(r_agreg) else if(associated(r_groupl_phi_ptr)) then allocate(r_groupl(im,jm,lm)) CALL CONVERT (a(irgp),lm,im,jm,r_groupl) do k=1,lm do j=1,jm do i=1,im r_groupl_phi_ptr(i,j,k)=aa*r_groupl_phi_ptr(i,j,k)+(1.-aa)*r_groupl_bias_ptr(i,j,k) r_groupl(i,j,k)=r_groupl(i,j,k)+r_groupl_phi_ptr(i,j,k) end do end do end do CALL CONVERT_inv (a(irgp),lm,im,jm,r_groupl) deallocate(r_groupl) else if(associated(r_hail_phi_ptr)) then allocate(r_hail(im,jm,lm)) CALL CONVERT (a(irhp),lm,im,jm,r_hail) do k=1,lm do j=1,jm do i=1,im r_hail_phi_ptr(i,j,k)=aa*r_hail_phi_ptr(i,j,k)+(1.-aa)*r_hail_bias_ptr(i,j,k) r_hail(i,j,k)=r_hail(i,j,k)+r_hail_phi_ptr(i,j,k) end do end do end do CALL CONVERT_inv (a(irhp),lm,im,jm,r_hail) deallocate(r_hail) else if(associated(r_cldliq_phi_ptr)) then allocate(r_cldliq(im,jm,lm)) CALL CONVERT (a(ircp),lm,im,jm,r_cldliq) do k=1,lm do j=1,jm do i=1,im r_cldliq_phi_ptr(i,j,k)=aa*r_cldliq_phi_ptr(i,j,k)+(1.-aa)*r_cldliq_bias_ptr(i,j,k) r_cldliq(i,j,k)=r_cldliq(i,j,k)+r_cldliq_phi_ptr(i,j,k) end do end do end do CALL CONVERT_inv (a(ircp),lm,im,jm,r_cldliq) deallocate(r_cldliq) else write(*,*) "PROBLEM: NO associated poiters were found" end if !!! if(associated(u_phi_ptr)) end if !!!! if(open_bias) then end subroutine bias_time !====================================================================== ! END OF BIAS_TIME !====================================================================== !====================================================================== ! BEGINNING OF READ_MODEL_BIAS !====================================================================== subroutine read_model_bias & (ifm,im,jm,lm,lg,ls) ! ********************************************************************** ! ! ROUTINE: read_model_bias: read file with bias ! used in ensda ! PRGMMR: D. ZUPANSKI ORG: CIRA/CSU DATE: 2003-09-17 ! ! ! REVISION HISTORY: ! ! 09/17/2003 ..... D. ZUPANSKI ! !----------------------------------------------------------------------- use ensda_variables implicit NONE integer :: ifm,im,jm,lm,lg,ls integer,parameter :: i_bias=410 ! starting bias file integer ubias,unitbfile,IER,i character(len=20) :: file_bias integer :: cvar_max1 character (len=9),dimension(:),allocatable :: cvar_name1 integer,dimension(:),allocatable :: & cvar_num_bias ! number of biases per cntrl vrbl character (len=9),dimension(:),allocatable :: & cvar_name ! cntrl vrbl name logical,dimension(:),allocatable :: & cvar_ic, &! init cond logical mask (per vrbl) cvar_param, &! empir param logical mask (per vrbl) cvar_bias ! model bias logical mask (per vrbl) !======================================================================================== if(open_bias) then !-- read control variable list --------------- CLOSE(103) OPEN(UNIT=103,FILE='cntrl_vrbl',FORM='FORMATTED',IOSTAT=IER) IF(IER.NE.0)WRITE(*,*)' 103 OPEN UNIT ERROR IER=',IER READ(103,*) cvar_max1 if(cvar_max.ne.cvar_max1) then write(*,*) "PROBLEM in READ_BIAS: cvar_max=",cvar_max," cvar_max1=",cvar_max1 stop else allocate(cvar_name(1:cvar_max)) allocate(cvar_ic(1:cvar_max)) allocate(cvar_param(1:cvar_max)) allocate(cvar_bias(1:cvar_max)) allocate(cvar_num_bias(1:cvar_max)) end if do i=1,cvar_max READ(103,*) cvar_name(i),cvar_ic(i),cvar_param(i),cvar_bias(i),cvar_num_bias(i) end do CLOSE(103,STATUS='KEEP') !------------------------------------------------- ubias=i_bias if(nbias.le.num_bias) then write(file_bias,1003) nbias 1003 format('model_bias_',i2.2) write(*,*) " file_bias =",file_bias unitbfile=ubias+nbias CLOSE(unitbfile) OPEN(UNIT=unitbfile,FILE=file_bias,FORM='UNFORMATTED',IOSTAT=IER) IF(IER.NE.0) WRITE(*,*) unitbfile,' OPEN UNIT ERROR IER=',IER allocate(cvar_name1(1:cvar_max)) do i=1,cvar_max if(cvar_bias(i)) then read(unitbfile) cvar_name1(i) if(cvar_name(i).ne.cvar_name1(i)) then write(*,*) "PROBLEM in READ_BIAS: cvar_name,cvar_name1=",cvar_name(i),cvar_name1(i) stop end if if(cvar_name(i).eq.'u ') then allocate(u_bias_gbl(1:im,1:jm,1:lm)) read(unitbfile) u_bias_gbl u_bias(:,:,:)=u_bias_gbl(:,:,:) write(*,*) " min,max u_bias=",minval(u_bias),maxval(u_bias) deallocate(u_bias_gbl) else if(cvar_name(i).eq.'v ') then allocate(v_bias_gbl(1:im,1:jm,1:lm)) read(unitbfile) v_bias_gbl v_bias(:,:,:)=v_bias_gbl(:,:,:) write(*,*) " min,max v_bias=",minval(v_bias),maxval(v_bias) deallocate(v_bias_gbl) else if(cvar_name(i).eq.'w ') then allocate(w_bias_gbl(1:im,1:jm,1:lm)) read(unitbfile) w_bias_gbl w_bias(:,:,:)=w_bias_gbl(:,:,:) write(*,*) " min,max w_bias=",minval(w_bias),maxval(w_bias) deallocate(w_bias_gbl) else if(cvar_name(i).eq.'exnr ') then allocate(exnr_bias_gbl(1:im,1:jm,1:lm)) read(unitbfile) exnr_bias_gbl exnr_bias(:,:,:)=exnr_bias_gbl(:,:,:) write(*,*) " min,max exnr_bias=",minval(exnr_bias),maxval(exnr_bias) deallocate(exnr_bias_gbl) else if(cvar_name(i).eq.'thetail ') then allocate(thetail_bias_gbl(1:im,1:jm,1:lm)) read(unitbfile) thetail_bias_gbl thetail_bias(:,:,:)=thetail_bias_gbl(:,:,:) write(*,*) " min,max thetail_bias=",minval(thetail_bias),maxval(thetail_bias) deallocate(thetail_bias_gbl) else if(cvar_name(i).eq.'r_total ') then allocate(r_total_bias_gbl(1:im,1:jm,1:lm)) read(unitbfile) r_total_bias_gbl r_total_bias(:,:,:)=r_total_bias_gbl(:,:,:) write(*,*) " min,max r_total_bias=",minval(r_total_bias),maxval(r_total_bias) deallocate(r_total_bias_gbl) else if(cvar_name(i).eq.'r_rain ') then allocate(r_rain_bias_gbl(1:im,1:jm,1:lm)) read(unitbfile) r_rain_bias_gbl r_rain_bias(:,:,:)=r_rain_bias_gbl(:,:,:) deallocate(r_rain_bias_gbl) else if(cvar_name(i).eq.'r_pice ') then allocate(r_pice_bias_gbl(1:im,1:jm,1:lm)) read(unitbfile) r_pice_bias_gbl r_pice_bias(:,:,:)=r_pice_bias_gbl(:,:,:) deallocate(r_pice_bias_gbl) else if(cvar_name(i).eq.'r_snow ') then allocate(r_snow_bias_gbl(1:im,1:jm,1:lm)) read(unitbfile) r_snow_bias_gbl r_snow_bias(:,:,:)=r_snow_bias_gbl(:,:,:) deallocate(r_snow_bias_gbl) else if(cvar_name(i).eq.'r_agreg ') then allocate(r_agreg_bias_gbl(1:im,1:jm,1:lm)) read(unitbfile) r_agreg_bias_gbl r_agreg_bias(:,:,:)=r_agreg_bias_gbl(:,:,:) deallocate(r_agreg_bias_gbl) else if(cvar_name(i).eq.'r_groupl ') then allocate(r_groupl_bias_gbl(1:im,1:jm,1:lm)) read(unitbfile) r_groupl_bias_gbl r_groupl_bias(:,:,:)=r_groupl_bias_gbl(:,:,:) deallocate(r_groupl_bias_gbl) else if(cvar_name(i).eq.'r_hail ') then allocate(r_hail_bias_gbl(1:im,1:jm,1:lm)) read(unitbfile) r_hail_bias_gbl r_hail_bias(:,:,:)=r_hail_bias_gbl(:,:,:) deallocate(r_hail_bias_gbl) else if(cvar_name(i).eq.'r_cldliq ') then allocate(r_cldliq_bias_gbl(1:im,1:jm,1:lm)) read(unitbfile) r_cldliq_bias_gbl r_cldliq_bias(:,:,:)=r_cldliq_bias_gbl(:,:,:) deallocate(r_cldliq_bias_gbl) else write(*,*)"WARNING: NO model bias found for i=",i end if !!! if(cvar_name(i).eq.'u ') end if !!! if(cvar_bias(i)) end do !!! do i=1,cvar_max CLOSE(unitbfile,status='KEEP') deallocate(cvar_name1) else write(*,*)"read_model_bias PROBLEM nbias=",nbias," num_bias=",num_bias endif !!! if(nbias.le.num_bias) deallocate(cvar_name) deallocate(cvar_ic) deallocate(cvar_param) deallocate(cvar_bias) deallocate(cvar_num_bias) end if !!! if(open_bias) end subroutine read_model_bias !====================================================================== ! END OF READ_MODEL_BIAS !====================================================================== !====================================================================== ! BEGINNING OF READ_MODEL_PARAM !====================================================================== subroutine read_model_param & (xparam) ! ********************************************************************** ! ! ROUTINE: read_model_param: read file with param ! used in ensda ! PRGMMR: D. ZUPANSKI ORG: CIRA/CSU DATE: 2003-09-17 ! ! ! REVISION HISTORY: ! ! 09/17/2003 ..... D. ZUPANSKI ! !----------------------------------------------------------------------- use ensda_variables implicit NONE real :: xparam integer,parameter :: i_param=403 ! empirical parameter file integer :: IER,i integer :: cvar_max1 character (len=9),dimension(:),allocatable :: cvar_name1 integer,dimension(:),allocatable :: & cvar_num_bias ! number of biases per cntrl vrbl character (len=9),dimension(:),allocatable :: & cvar_name ! cntrl vrbl name logical,dimension(:),allocatable :: & cvar_ic, &! init cond logical mask (per vrbl) cvar_param, &! empir param logical mask (per vrbl) cvar_bias ! model bias logical mask (per vrbl) !======================================================================================= if(open_param) then !-- read control variable list --------------- CLOSE(103) OPEN(UNIT=103,FILE='cntrl_vrbl',FORM='FORMATTED',IOSTAT=IER) IF(IER.NE.0)WRITE(*,*)' 103 OPEN UNIT ERROR IER=',IER READ(103,*) cvar_max1 if(cvar_max.ne.cvar_max1) then write(*,*) "PROBLEM in READ_PARAM: cvar_max=",cvar_max," cvar_max1=",cvar_max1 stop else allocate(cvar_name(1:cvar_max)) allocate(cvar_ic(1:cvar_max)) allocate(cvar_param(1:cvar_max)) allocate(cvar_bias(1:cvar_max)) allocate(cvar_num_bias(1:cvar_max)) end if do i=1,cvar_max READ(103,*) cvar_name(i),cvar_ic(i),cvar_param(i),cvar_bias(i),cvar_num_bias(i) end do CLOSE(103,STATUS='KEEP') !------------------------------------------------- CLOSE(i_param) OPEN(UNIT=i_param,FILE='model_param',FORM='UNFORMATTED',IOSTAT=IER) IF(IER.NE.0) WRITE(*,*) i_param,' OPEN UNIT ERROR IER=',IER allocate(cvar_name1(1:cvar_max)) do i=1,cvar_max if(cvar_param(i)) then read(i_param) cvar_name1(i) if(cvar_name(i).ne.cvar_name1(i)) then write(*,*) "PROBLEM in READ_PARAM: cvar_name,cvar_name1=",cvar_name(i),cvar_name1(i) stop end if if(cvar_name(i).eq.'xparam ') then read(i_param) xparam end if end if !!!! if(cvar_param(i)) enddo deallocate(cvar_name1) CLOSE(i_param,status='KEEP') deallocate(cvar_name) deallocate(cvar_ic) deallocate(cvar_param) deallocate(cvar_bias) deallocate(cvar_num_bias) end if !!! if(open_param) end subroutine read_model_param !====================================================================== ! END OF READ_MODEL_PARAM !====================================================================== !====================================================================== ! BEGINNING OF READ_MODEL_IC !====================================================================== subroutine read_model_ic & (A,ifm,im,jm,lm,lg,ls, & iuc,ivc,iwc,ipc,ithp,irtp,irrp,irpp,irsp,irap,irgp, & irhp,ircp, & irv,itheta) ! ********************************************************************** ! ! ROUTINE: read_model_ic: read file with ic ! used in ensda ! PRGMMR: D. ZUPANSKI ORG: CIRA/CSU DATE: 2003-09-17 ! ! ! REVISION HISTORY: ! ! 09/17/2003 ..... D. ZUPANSKI ! !----------------------------------------------------------------------- use ensda_variables implicit NONE integer :: ifm,im,jm,lm,lg,ls integer :: iuc,ivc,iwc,ipc,ithp,irtp, & irrp,irpp,irsp,irap,irgp, & irhp,ircp, & irv,itheta real,dimension(*) :: A integer,parameter :: i_ic=402 ! initial conditions file integer IER,i,ii,jj,ll integer :: cvar_max1 character (len=9),dimension(:),allocatable :: cvar_name1 integer,dimension(:),allocatable :: & cvar_num_bias ! number of biases per cntrl vrbl character (len=9),dimension(:),allocatable :: & cvar_name ! cntrl vrbl name logical,dimension(:),allocatable :: & cvar_ic, &! init cond logical mask (per vrbl) cvar_param, &! empir param logical mask (per vrbl) cvar_bias ! model bias logical mask (per vrbl) !============================================================================= if(open_ic) then !-- read control variable list --------------- CLOSE(103) OPEN(UNIT=103,FILE='cntrl_vrbl',FORM='FORMATTED',IOSTAT=IER) IF(IER.NE.0)WRITE(*,*)' 103 OPEN UNIT ERROR IER=',IER READ(103,*) cvar_max1 if(cvar_max.ne.cvar_max1) then write(*,*) "PROBLEM in READ_IC: cvar_max=",cvar_max," cvar_max1=",cvar_max1 stop else allocate(cvar_name(1:cvar_max)) allocate(cvar_ic(1:cvar_max)) allocate(cvar_param(1:cvar_max)) allocate(cvar_bias(1:cvar_max)) allocate(cvar_num_bias(1:cvar_max)) end if do i=1,cvar_max READ(103,*) cvar_name(i),cvar_ic(i),cvar_param(i),cvar_bias(i),cvar_num_bias(i) end do CLOSE(103,STATUS='KEEP') !------------------------------------------------- CLOSE(i_ic) OPEN(UNIT=i_ic,FILE='model_ic',FORM='UNFORMATTED',IOSTAT=IER) IF(IER.NE.0) WRITE(*,*) i_ic,' OPEN UNIT ERROR IER=',IER allocate(cvar_name1(1:cvar_max)) do i=1,cvar_max if(cvar_ic(i)) then read(i_ic) cvar_name1(i) if(cvar_name(i).ne.cvar_name1(i)) then write(*,*) "PROBLEM in READ_IC: cvar_name,cvar_name1=",cvar_name(i),cvar_name1(i) stop end if if(cvar_name(i).eq.'u ') then allocate(u(im,jm,lm)) read(i_ic) u CALL CONVERT_inv (a(iuc),lm,im,jm,u) deallocate(u) elseif(cvar_name(i).eq.'v ') then allocate(v(im,jm,lm)) read(i_ic) v CALL CONVERT_inv (a(ivc),lm,im,jm,v) deallocate(v) elseif(cvar_name(i).eq.'w ') then allocate(w(im,jm,lm)) read(i_ic) w CALL CONVERT_inv (a(iwc),lm,im,jm,w) deallocate(w) elseif(cvar_name(i).eq.'exnr ') then allocate(exnr(im,jm,lm)) read(i_ic) exnr CALL CONVERT_inv (a(ipc),lm,im,jm,exnr) deallocate(exnr) elseif(cvar_name(i).eq.'thetail ') then allocate(thetail(im,jm,lm)) read(i_ic) thetail CALL CONVERT_inv (a(ithp),lm,im,jm,thetail) deallocate(thetail) elseif(cvar_name(i).eq.'r_total ') then allocate(r_total(im,jm,lm)) read(i_ic) r_total do ll=1,lm do jj=1,jm do ii=1,im if(r_total(ii,jj,ll).lt.0.) r_total(ii,jj,ll)=0.0 enddo enddo enddo CALL CONVERT_inv (a(irtp),lm,im,jm,r_total) deallocate(r_total) elseif(cvar_name(i).eq.'r_rain ') then allocate(r_rain(im,jm,lm)) read(i_ic) r_rain do ll=1,lm do jj=1,jm do ii=1,im if(r_rain(ii,jj,ll).lt.0.) r_rain(ii,jj,ll)=0.0 enddo enddo enddo CALL CONVERT_inv (a(irrp),lm,im,jm,r_rain) deallocate(r_rain) elseif(cvar_name(i).eq.'r_pice ') then allocate(r_pice(im,jm,lm)) read(i_ic) r_pice do ll=1,lm do jj=1,jm do ii=1,im if(r_pice(ii,jj,ll).lt.0.) r_pice(ii,jj,ll)=0.0 enddo enddo enddo CALL CONVERT_inv (a(irpp),lm,im,jm,r_pice) deallocate(r_pice) elseif(cvar_name(i).eq.'r_snow ') then allocate(r_snow(im,jm,lm)) read(i_ic) r_snow do ll=1,lm do jj=1,jm do ii=1,im if(r_snow(ii,jj,ll).lt.0.) r_snow(ii,jj,ll)=0.0 enddo enddo enddo CALL CONVERT_inv (a(irsp),lm,im,jm,r_snow) deallocate(r_snow) elseif(cvar_name(i).eq.'r_agreg ') then allocate(r_agreg(im,jm,lm)) read(i_ic) r_agreg do ll=1,lm do jj=1,jm do ii=1,im if(r_agreg(ii,jj,ll).lt.0.) r_agreg(ii,jj,ll)=0.0 enddo enddo enddo CALL CONVERT_inv (a(irap),lm,im,jm,r_agreg) deallocate(r_agreg) elseif(cvar_name(i).eq.'r_groupl ') then allocate(r_groupl(im,jm,lm)) read(i_ic) r_groupl do ll=1,lm do jj=1,jm do ii=1,im if(r_groupl(ii,jj,ll).lt.0.) r_groupl(ii,jj,ll)=0.0 enddo enddo enddo CALL CONVERT_inv (a(irgp),lm,im,jm,r_groupl) deallocate(r_groupl) elseif(cvar_name(i).eq.'r_hail ') then allocate(r_hail(im,jm,lm)) read(i_ic) r_hail do ll=1,lm do jj=1,jm do ii=1,im if(r_hail(ii,jj,ll).lt.0.) r_hail(ii,jj,ll)=0.0 enddo enddo enddo CALL CONVERT_inv (a(irhp),lm,im,jm,r_hail) deallocate(r_hail) elseif(cvar_name(i).eq.'r_cldliq ') then allocate(r_cldliq(im,jm,lm)) read(i_ic) r_cldliq do ll=1,lm do jj=1,jm do ii=1,im if(r_cldliq(ii,jj,ll).lt.0.) r_cldliq(ii,jj,ll)=0.0 enddo enddo enddo CALL CONVERT_inv (a(ircp),lm,im,jm,r_cldliq) deallocate(r_cldliq) else write(*,*) "PROBLEM: NO control variables were found" end if !!! if(cvar_name(i).eq.'u ') end if !!! if(cvar_ic(i)) end do !!! do i=1,cvar_max CLOSE(i_ic,status='KEEP') deallocate(cvar_name1) deallocate(cvar_name) deallocate(cvar_ic) deallocate(cvar_param) deallocate(cvar_bias) deallocate(cvar_num_bias) end if !!! if(open_ic) end subroutine read_model_ic !====================================================================== ! END OF READ_MODEL_IC !====================================================================== !====================================================================== ! BEGINNING OF WRITE_MODEL_BIAS !====================================================================== subroutine write_model_bias & (ifm,im,jm,lm,lg,ls) ! ********************************************************************** ! ! ROUTINE: write_model_bias: write file with bias ! used in ensda ! PRGMMR: D. ZUPANSKI ORG: CIRA/CSU DATE: 2003-09-17 ! ! ! REVISION HISTORY: ! ! 09/17/2003 ..... D. ZUPANSKI ! !----------------------------------------------------------------------- use ensda_variables implicit NONE integer :: ifm,im,jm,lm,lg,ls integer,parameter :: i_bias=410 ! starting bias file integer ubias,unitbfile,IER,i character(len=20) :: file_bias integer :: cvar_max1 integer,dimension(:),allocatable :: & cvar_num_bias ! number of biases per cntrl vrbl character (len=9),dimension(:),allocatable :: & cvar_name ! cntrl vrbl name logical,dimension(:),allocatable :: & cvar_ic, &! init cond logical mask (per vrbl) cvar_param, &! empir param logical mask (per vrbl) cvar_bias ! model bias logical mask (per vrbl) !============================================================================== if(open_bias) then !-- read control variable list --------------- CLOSE(103) OPEN(UNIT=103,FILE='cntrl_vrbl',FORM='FORMATTED',IOSTAT=IER) IF(IER.NE.0)WRITE(*,*)' 103 OPEN UNIT ERROR IER=',IER READ(103,*) cvar_max1 if(cvar_max.ne.cvar_max1) then write(*,*) "PROBLEM in WRITE_BIAS: cvar_max=",cvar_max," cvar_max1=",cvar_max1 stop else allocate(cvar_name(1:cvar_max)) allocate(cvar_ic(1:cvar_max)) allocate(cvar_param(1:cvar_max)) allocate(cvar_bias(1:cvar_max)) allocate(cvar_num_bias(1:cvar_max)) end if do i=1,cvar_max READ(103,*) cvar_name(i),cvar_ic(i),cvar_param(i),cvar_bias(i),cvar_num_bias(i) end do CLOSE(103,STATUS='KEEP') !------------------------------------------------- ubias=i_bias if(nbias.le.num_bias) then write(file_bias,1003) nbias 1003 format('model_bias_',i2.2) write(*,*) " file_bias =",file_bias unitbfile=ubias+nbias CLOSE(unitbfile) OPEN(UNIT=unitbfile,FILE=file_bias,FORM='UNFORMATTED',IOSTAT=IER) IF(IER.NE.0) WRITE(*,*) unitbfile,' OPEN UNIT ERROR IER=',IER do i=1,cvar_max if(cvar_bias(i)) then if(cvar_name(i).eq.'u ') then allocate(u_bias_gbl(1:im,1:jm,1:lm)) write(unitbfile) cvar_name(i) u_bias_gbl(:,:,:)=u_bias(:,:,:) write(unitbfile) u_bias_gbl deallocate(u_bias_gbl) else if(cvar_name(i).eq.'v ') then allocate(v_bias_gbl(1:im,1:jm,1:lm)) write(unitbfile) cvar_name(i) v_bias_gbl(:,:,:)=v_bias(:,:,:) write(unitbfile) v_bias_gbl deallocate(v_bias_gbl) else if(cvar_name(i).eq.'w ') then allocate(w_bias_gbl(1:im,1:jm,1:lm)) write(unitbfile) cvar_name(i) w_bias_gbl(:,:,:)=w_bias(:,:,:) write(unitbfile) w_bias_gbl deallocate(w_bias_gbl) else if(cvar_name(i).eq.'exnr ') then allocate(exnr_bias_gbl(1:im,1:jm,1:lm)) write(unitbfile) cvar_name(i) exnr_bias_gbl(:,:,:)=exnr_bias(:,:,:) write(unitbfile) exnr_bias_gbl deallocate(exnr_bias_gbl) else if(cvar_name(i).eq.'thetail ') then allocate(thetail_bias_gbl(1:im,1:jm,1:lm)) write(unitbfile) cvar_name(i) thetail_bias_gbl(:,:,:)=thetail_bias(:,:,:) write(unitbfile) thetail_bias_gbl deallocate(thetail_bias_gbl) else if(cvar_name(i).eq.'r_total ') then allocate(r_total_bias_gbl(1:im,1:jm,1:lm)) write(unitbfile) cvar_name(i) r_total_bias_gbl(:,:,:)=r_total_bias(:,:,:) write(unitbfile) r_total_bias_gbl deallocate(r_total_bias_gbl) else if(cvar_name(i).eq.'r_rain ') then allocate(r_rain_bias_gbl(1:im,1:jm,1:lm)) write(unitbfile) cvar_name(i) r_rain_bias_gbl(:,:,:)=r_rain_bias(:,:,:) write(unitbfile) r_rain_bias_gbl deallocate(r_rain_bias_gbl) else if(cvar_name(i).eq.'r_pice ') then allocate(r_pice_bias_gbl(1:im,1:jm,1:lm)) write(unitbfile) cvar_name(i) r_pice_bias_gbl(:,:,:)=r_pice_bias(:,:,:) write(unitbfile) r_pice_bias_gbl deallocate(r_pice_bias_gbl) else if(cvar_name(i).eq.'r_snow ') then allocate(r_snow_bias_gbl(1:im,1:jm,1:lm)) write(unitbfile) cvar_name(i) r_snow_bias_gbl(:,:,:)=r_snow_bias(:,:,:) write(unitbfile) r_snow_bias_gbl deallocate(r_snow_bias_gbl) else if(cvar_name(i).eq.'r_agreg ') then allocate(r_agreg_bias_gbl(1:im,1:jm,1:lm)) write(unitbfile) cvar_name(i) r_agreg_bias_gbl(:,:,:)=r_agreg_bias(:,:,:) write(unitbfile) r_agreg_bias_gbl deallocate(r_agreg_bias_gbl) else if(cvar_name(i).eq.'r_groupl ') then allocate(r_groupl_bias_gbl(1:im,1:jm,1:lm)) write(unitbfile) cvar_name(i) r_groupl_bias_gbl(:,:,:)=r_groupl_bias(:,:,:) write(unitbfile) r_groupl_bias_gbl deallocate(r_groupl_bias_gbl) else if(cvar_name(i).eq.'r_hail ') then allocate(r_hail_bias_gbl(1:im,1:jm,1:lm)) write(unitbfile) cvar_name(i) r_hail_bias_gbl(:,:,:)=r_hail_bias(:,:,:) write(unitbfile) r_hail_bias_gbl deallocate(r_hail_bias_gbl) else if(cvar_name(i).eq.'r_cldliq ') then allocate(r_cldliq_bias_gbl(1:im,1:jm,1:lm)) write(unitbfile) cvar_name(i) r_cldliq_bias_gbl(:,:,:)=r_cldliq_bias(:,:,:) write(unitbfile) r_cldliq_bias_gbl deallocate(r_cldliq_bias_gbl) else write(*,*)"WARNING: NO model bias found for i=",i end if !!! if(cvar_name(i).eq.'u ') endif !!! if(cvar_bias(i)) end do !!! do i=1,cvar_max CLOSE(unitbfile,status='KEEP') else write(*,*)"write_model_bias PROBLEM nbias=",nbias," num_bias=",num_bias endif !!! if(nbias.le.num_bias) deallocate(cvar_name) deallocate(cvar_ic) deallocate(cvar_param) deallocate(cvar_bias) deallocate(cvar_num_bias) end if !!! if(open_bias) end subroutine write_model_bias !====================================================================== ! END OF WRITE_MODEL_BIAS !====================================================================== !====================================================================== ! BEGINNING OF WRITE_MODEL_PARAM !====================================================================== subroutine write_model_param & (xparam) ! ********************************************************************** ! ! ROUTINE: write_model_param: write file with param ! used in ensda ! PRGMMR: D. ZUPANSKI ORG: CIRA/CSU DATE: 2003-09-17 ! ! ! REVISION HISTORY: ! ! 09/17/2003 ..... D. ZUPANSKI ! !----------------------------------------------------------------------- use ensda_variables implicit NONE real :: xparam integer,parameter :: i_param=403 ! empirical parameter file integer IER,i integer :: cvar_max1 integer,dimension(:),allocatable :: & cvar_num_bias ! number of biases per cntrl vrbl character (len=9),dimension(:),allocatable :: & cvar_name ! cntrl vrbl name logical,dimension(:),allocatable :: & cvar_ic, &! init cond logical mask (per vrbl) cvar_param, &! empir param logical mask (per vrbl) cvar_bias ! model bias logical mask (per vrbl) !=========================================================================== if(open_param) then !-- read control variable list --------------- CLOSE(103) OPEN(UNIT=103,FILE='cntrl_vrbl',FORM='FORMATTED',IOSTAT=IER) IF(IER.NE.0)WRITE(*,*)' 103 OPEN UNIT ERROR IER=',IER READ(103,*) cvar_max1 if(cvar_max.ne.cvar_max1) then write(*,*) "PROBLEM in WRITE_PARAM: cvar_max=",cvar_max," cvar_max1=",cvar_max1 stop else allocate(cvar_name(1:cvar_max)) allocate(cvar_ic(1:cvar_max)) allocate(cvar_param(1:cvar_max)) allocate(cvar_bias(1:cvar_max)) allocate(cvar_num_bias(1:cvar_max)) end if do i=1,cvar_max READ(103,*) cvar_name(i),cvar_ic(i),cvar_param(i),cvar_bias(i),cvar_num_bias(i) end do CLOSE(103,STATUS='KEEP') !------------------------------------------------- CLOSE(i_param) OPEN(UNIT=i_param,FILE='model_param',FORM='UNFORMATTED',IOSTAT=IER) IF(IER.NE.0) WRITE(*,*) i_param,' OPEN UNIT ERROR IER=',IER do i=1,cvar_max if(cvar_param(i)) then if(cvar_name(i).eq.'xparam ') then write(i_param) cvar_name(i) write(i_param) xparam end if end if enddo CLOSE(i_param,status='KEEP') deallocate(cvar_name) deallocate(cvar_ic) deallocate(cvar_param) deallocate(cvar_bias) deallocate(cvar_num_bias) end if !!! if(open_param) end subroutine write_model_param !====================================================================== ! END OF WRITE_MODEL_PARAM !====================================================================== !====================================================================== ! BEGINNING OF WRITE_MODEL_IC !====================================================================== subroutine write_model_ic & (A,ifm,im,jm,lm,lg,ls, & iuc,ivc,iwc,ipc,ithp,irtp,irrp,irpp,irsp,irap,irgp, & irhp,ircp, & irv,itheta) ! ********************************************************************** ! ! ROUTINE: write_model_ic: write file with ic ! used in ensda ! PRGMMR: D. ZUPANSKI ORG: CIRA/CSU DATE: 2003-09-17 ! ! ! REVISION HISTORY: ! ! 09/17/2003 ..... D. ZUPANSKI ! !----------------------------------------------------------------------- use ensda_variables implicit NONE integer :: ifm,im,jm,lm,lg,ls integer :: iuc,ivc,iwc,ipc,ithp,irtp, & irrp,irpp,irsp,irap,irgp, & irhp,ircp, & irv,itheta real,dimension(*) :: A integer,parameter :: i_ic=402 ! initial conditions file integer IER,i integer i1,i2,ii,jj,ll integer :: cvar_max1 integer,dimension(:),allocatable :: & cvar_num_bias ! number of biases per cntrl vrbl character(len=9),dimension(:),allocatable :: & cvar_name ! cntrl vrbl name logical,dimension(:),allocatable :: & cvar_ic, &! init cond logical mask (per vrbl) cvar_param, &! empir param logical mask (per vrbl) cvar_bias ! model bias logical mask (per vrbl) !=============================================================================== if(open_ic) then !-- read control variable list --------------- CLOSE(103) OPEN(UNIT=103,FILE='cntrl_vrbl',FORM='FORMATTED',IOSTAT=IER) IF(IER.NE.0)WRITE(*,*)' 103 OPEN UNIT ERROR IER=',IER READ(103,*) cvar_max1 if(cvar_max.ne.cvar_max1) then write(*,*) "PROBLEM in WRITE_IC: cvar_max=",cvar_max," cvar_max1=",cvar_max1 stop else allocate(cvar_name(1:cvar_max)) allocate(cvar_ic(1:cvar_max)) allocate(cvar_param(1:cvar_max)) allocate(cvar_bias(1:cvar_max)) allocate(cvar_num_bias(1:cvar_max)) end if do i=1,cvar_max READ(103,*) cvar_name(i),cvar_ic(i),cvar_param(i),cvar_bias(i),cvar_num_bias(i) end do CLOSE(103,STATUS='KEEP') !------------------------------------------------- CLOSE(i_ic) OPEN(UNIT=i_ic,FILE='model_ic',FORM='UNFORMATTED',IOSTAT=IER) IF(IER.NE.0) WRITE(*,*) i_ic,' OPEN UNIT ERROR IER=',IER do i=1,cvar_max if(cvar_ic(i)) then if(cvar_name(i).eq.'u ') then allocate(u(im,jm,lm)) write(i_ic) cvar_name(i) CALL CONVERT (a(iuc),lm,im,jm,u) write(i_ic) u deallocate(u) elseif(cvar_name(i).eq.'v ') then allocate(v(im,jm,lm)) write(i_ic) cvar_name(i) CALL CONVERT (a(ivc),lm,im,jm,v) write(i_ic) v deallocate(v) elseif(cvar_name(i).eq.'w ') then allocate(w(im,jm,lm)) write(i_ic) cvar_name(i) CALL CONVERT (a(iwc),lm,im,jm,w) write(i_ic) w deallocate(w) elseif(cvar_name(i).eq.'exnr ') then allocate(exnr(im,jm,lm)) write(i_ic) cvar_name(i) CALL CONVERT (a(ipc),lm,im,jm,exnr) write(i_ic) exnr deallocate(exnr) elseif(cvar_name(i).eq.'thetail ') then allocate(thetail(im,jm,lm)) write(i_ic) cvar_name(i) CALL CONVERT (a(ithp),lm,im,jm,thetail) write(i_ic) thetail deallocate(thetail) elseif(cvar_name(i).eq.'r_total ') then allocate(r_total(im,jm,lm)) write(i_ic) cvar_name(i) CALL CONVERT (a(irtp),lm,im,jm,r_total) do ll=1,lm do jj=1,jm do ii=1,im if(r_total(ii,jj,ll).lt.0.) r_total(ii,jj,ll)=0.0 enddo enddo enddo write(i_ic) r_total deallocate(r_total) elseif(cvar_name(i).eq.'r_rain ') then allocate(r_rain(im,jm,lm)) write(i_ic) cvar_name(i) CALL CONVERT (a(irrp),lm,im,jm,r_rain) do ll=1,lm do jj=1,jm do ii=1,im if(r_rain(ii,jj,ll).lt.0.) r_rain(ii,jj,ll)=0.0 enddo enddo enddo write(i_ic) r_rain deallocate(r_rain) elseif(cvar_name(i).eq.'r_pice ') then allocate(r_pice(im,jm,lm)) write(i_ic) cvar_name(i) CALL CONVERT (a(irpp),lm,im,jm,r_pice) do ll=1,lm do jj=1,jm do ii=1,im if(r_pice(ii,jj,ll).lt.0.) r_pice(ii,jj,ll)=0.0 enddo enddo enddo write(i_ic) r_pice deallocate(r_pice) elseif(cvar_name(i).eq.'r_snow ') then allocate(r_snow(im,jm,lm)) write(i_ic) cvar_name(i) CALL CONVERT (a(irsp),lm,im,jm,r_snow) do ll=1,lm do jj=1,jm do ii=1,im if(r_snow(ii,jj,ll).lt.0.) r_snow(ii,jj,ll)=0.0 enddo enddo enddo write(i_ic) r_snow deallocate(r_snow) elseif(cvar_name(i).eq.'r_agreg ') then allocate(r_agreg(im,jm,lm)) write(i_ic) cvar_name(i) CALL CONVERT (a(irap),lm,im,jm,r_agreg) do ll=1,lm do jj=1,jm do ii=1,im if(r_agreg(ii,jj,ll).lt.0.) r_agreg(ii,jj,ll)=0.0 enddo enddo enddo write(i_ic) r_agreg deallocate(r_agreg) elseif(cvar_name(i).eq.'r_groupl ') then allocate(r_groupl(im,jm,lm)) write(i_ic) cvar_name(i) CALL CONVERT (a(irgp),lm,im,jm,r_groupl) do ll=1,lm do jj=1,jm do ii=1,im if(r_groupl(ii,jj,ll).lt.0.) r_groupl(ii,jj,ll)=0.0 enddo enddo enddo write(i_ic) r_groupl deallocate(r_groupl) elseif(cvar_name(i).eq.'r_hail ') then allocate(r_hail(im,jm,lm)) write(i_ic) cvar_name(i) CALL CONVERT (a(irhp),lm,im,jm,r_hail) do ll=1,lm do jj=1,jm do ii=1,im if(r_hail(ii,jj,ll).lt.0.) r_hail(ii,jj,ll)=0.0 enddo enddo enddo write(i_ic) r_hail deallocate(r_hail) elseif(cvar_name(i).eq.'r_cldliq ') then allocate(r_cldliq(im,jm,lm)) write(i_ic) cvar_name(i) CALL CONVERT (a(ircp),lm,im,jm,r_cldliq) do ll=1,lm do jj=1,jm do ii=1,im if(r_cldliq(ii,jj,ll).lt.0.) r_cldliq(ii,jj,ll)=0.0 enddo enddo enddo write(i_ic) r_cldliq deallocate(r_cldliq) else write(*,*) "PROBLEM: NO control variables were found" end if !!! if(cvar_name(i).eq.'u ') end if !!! if(cvar_ic(i)) end do !!! do i=1,cvar_max CLOSE(i_ic,status='KEEP') deallocate(cvar_name) deallocate(cvar_ic) deallocate(cvar_param) deallocate(cvar_bias) deallocate(cvar_num_bias) end if !!! if(open_ic) end subroutine write_model_ic !====================================================================== ! END OF WRITE_MODEL_IC !====================================================================== !====================================================================== ! BEGINNING OF CONVERT !====================================================================== subroutine convert(aa,lm,im,jm,c) ! ********************************************************************** ! ! ROUTINE: convert: Converts RAMS variable A into a 3d variable ! ! PRGMMR: D. ZUPANSKI ORG: CIRA/CSU DATE: 2004-06-17 ! ! ! REVISION HISTORY: ! ! 06/17/2003 ..... D. ZUPANSKI ! !----------------------------------------------------------------------- real,dimension(lm,im,jm)::aa real,dimension(im,jm,lm)::c do j=1,jm do i=1,im do k=1,lm c(i,j,k)=aa(k,i,j) enddo enddo enddo end subroutine convert !====================================================================== ! END OF CONVERT !====================================================================== !====================================================================== ! BEGINNING OF CONVERT_inv !====================================================================== subroutine convert_inv(aa,lm,im,jm,c) ! ********************************************************************** ! ! ROUTINE: convert: Converts a 3d variable into RAMS variable A ! ! PRGMMR: D. ZUPANSKI ORG: CIRA/CSU DATE: 2004-06-17 ! ! ! REVISION HISTORY: ! ! 06/17/2003 ..... D. ZUPANSKI ! !----------------------------------------------------------------------- real,dimension(lm,im,jm)::aa real,dimension(im,jm,lm)::c do j=1,jm do i=1,im do k=1,lm aa(k,i,j)=c(i,j,k) enddo enddo enddo end subroutine convert_inv !====================================================================== ! END OF CONVERT_inv !======================================================================