program convert_vrbls_to_1d ! ********************************************************************** ! * . . . ! * PROGRAM: convert_vrbls_to_1d ! * ! * PRGMMR: M. ZUPANSKI, D. ZUPANSKI ORG: CIRA/CSU DATE: 2003-08-14 ! * ! * ABSTRACT: THIS SUBROUTINE CONVERTS CONTROL (FCST) VARIABLES FROM ! * N-DIMENSIONAL VARIABLE TO 1-DIMENSIONAL VARIABLE ! * AND WRITES OUT THE 1-DIMENSIONAL VARIABLE. ! * ! * PROGRAM LOG: ! * ! * 08/14/2003 ..... M. ZUPANSKI, D. ZUPANSKI ! * 09/12/2003 ..... D. ZUPANSKI ! * ! ********************************************************************** integer,parameter :: i_ic=51 ! initial conditions file integer,parameter :: i_param=52 ! empirical parameter file integer,parameter :: i_bias=53 ! starting bias file INCLUDE 'define_var_list_type.h' INCLUDE 'define_cvar_type.h' TYPE (var_list_type), dimension(:), allocatable :: cvar_list TYPE (cvar_type), dimension(:), allocatable :: cvar real, dimension(:), allocatable :: x real, dimension(:), allocatable :: cvar1d real, dimension(:,:), allocatable :: cvar2d real, dimension(:,:,:), allocatable :: cvar3d real, dimension(:,:,:,:), allocatable :: cvar4d real :: cvarparm integer, dimension(1) :: NNXP,NNYP,NNZP,NNSOIL,NNSNOW integer, dimension(:), allocatable :: unitbias integer :: cvar_max integer :: ubias,unitbfile,nbias,num_bias character*20 :: filename character*20 :: file_ic,file_param,file_bias character*9 :: cv_name,cv_name_read logical :: open_ic,open_param,open_bias !------------------------------ NAMELIST /MODEL_DIMENSION/ NNXP,NNYP,NNZP,NNSOIL,NNSNOW !------------------------------ write(*,*) " start convert_vrbls_to_1d" !--- get model dimensions write(filename,200) 200 format('model_dimension.name') CLOSE(500) OPEN(UNIT=500,FILE=filename,FORM='FORMATTED',IOSTAT=IER) IF(IER.NE.0) WRITE(3,*)' 500 OPEN UNIT ERROR IER=',IER READ(500,MODEL_DIMENSION) CLOSE(500,STATUS='KEEP') write(*,*) "NNXP=",NNXP(1)," NNYP=",NNYP(1)," NNZP=",NNZP(1) INCLUDE 'cntrl_vrbl_list.h' write(*,*) "max_num_of_cntrl_vrbls=",max_num_of_cntrl_vrbls do ncv=1,max_num_of_cntrl_vrbls write(*,*) "ndim ",cvar_list(ncv)%ndim write(*,*) "start1 ",cvar_list(ncv)%start_index(1) write(*,*) "start2 ",cvar_list(ncv)%start_index(2) write(*,*) "start3 ",cvar_list(ncv)%start_index(3) write(*,*) "start4 ",cvar_list(ncv)%start_index(4) write(*,*) "end1 ",cvar_list(ncv)%end_index(1) write(*,*) "end2 ",cvar_list(ncv)%end_index(2) write(*,*) "end3 ",cvar_list(ncv)%end_index(3) write(*,*) "end4 ",cvar_list(ncv)%end_index(4) write(*,*) "name ",cvar_list(ncv)%name write(*,*) "description ",cvar_list(ncv)%description end do CLOSE(103) OPEN(103,FILE='cntrl_vrbl',FORM='FORMATTED',IOSTAT=IER) IF(IER.NE.0)WRITE(*,*)' 103 OPEN UNIT ERROR IER=',IER READ(103,*) cvar_max allocate(cvar(1:cvar_max)) open_ic=.FALSE. open_param=.FALSE. open_bias=.FALSE. do i=1,cvar_max READ(103,*) cvar(i) write(*,*) cvar(i) if(cvar(i)%ic) then open_ic=.TRUE. end if if(cvar(i)%param) then open_param=.TRUE. end if if(cvar(i)%bias) then open_bias=.TRUE. num_bias=cvar(i)%num_bias end if ! READ(103,*) name,ic,param,bias,num_bias !! read in the model ! READ(103,*) cvar(i)%name,cvar(i)%ic,cvar(i)%param,cvar(i)%bias,cvar(i)%num_bias ! write(*,*) cvar(i)%name,cvar(i)%ic,cvar(i)%param,cvar(i)%bias,cvar(i)%num_bias end do CLOSE(103,STATUS='KEEP') !========== start reading 1d control variable ============== ! open input files rewind 20 READ(20) idim_1d allocate(x(1:idim_1d)) !---------------------------------------------- ! open output files if(open_ic) then write(file_ic,1001) 1001 format('model_ic') write(*,*) "output n-dimensional model_ic filename=",file_ic CLOSE(i_ic) OPEN(UNIT=i_ic,FILE=file_ic,FORM='UNFORMATTED',IOSTAT=IER) IF(IER.NE.0) WRITE(*,*) i_ic,' OPEN UNIT ERROR IER=',IER end if if(open_param) then write(file_param,1002) 1002 format('model_param') write(*,*) "output n-dimensional model_param filename=",file_param CLOSE(i_param) OPEN(UNIT=i_param,FILE=file_param,FORM='UNFORMATTED',IOSTAT=IER) IF(IER.NE.0) WRITE(*,*) i_param,' OPEN UNIT ERROR IER=',IER end if if(open_bias) then allocate(unitbias(0:num_bias)) ubias=i_bias do nbias=1,num_bias write(file_bias,1003) nbias 1003 format('model_bias_',i2.2) write(*,*) "output n-dimensional model_bias filename=",file_bias unitbias(nbias)=ubias+nbias unitbfile=unitbias(nbias) CLOSE(unitbfile) OPEN(UNIT=unitbfile,FILE=file_bias,FORM='UNFORMATTED',IOSTAT=IER) IF(IER.NE.0) WRITE(*,*) unitbfile,' OPEN UNIT ERROR IER=',IER end do end if !---------------------------------------------- icount=0 nvar=0 do i=1,cvar_max write(*,*) "do i=",i do j=1,max_num_of_cntrl_vrbls write(*,*) "do j=",j if(cvar(i)%name.eq.cvar_list(j)%name) then nvar=nvar+1 i1s=cvar_list(j)%start_index(1) i2s=cvar_list(j)%start_index(2) i3s=cvar_list(j)%start_index(3) i4s=cvar_list(j)%start_index(4) i1e=cvar_list(j)%end_index(1) i2e=cvar_list(j)%end_index(2) i3e=cvar_list(j)%end_index(3) i4e=cvar_list(j)%end_index(4) !-- initial conditions if(cvar(i)%ic) then cv_name=cvar(i)%name if(cvar_list(j)%ndim.eq.4) then read(i_ic) cv_name_read if(cv_name .eq. cv_name_read) then allocate(cvar4d(i1s:i1e,i2s:i2e,i3s:i3e,i4s:i4e)) read(i_ic) cvar4d do i4=i4s,i4e do i3=i3s,i3e do i2=i2s,i2e do i1=i1s,i1e icount=icount+1 x(icount)=cvar4d(i1,i2,i3,i4) end do end do end do end do deallocate(cvar4d) else write(*,*)" convert_vrbls_to_1d, PROBLEM with cv_name_read=",cv_name_read stop endif else if(cvar_list(j)%ndim.eq.3) then read(i_ic) cv_name_read if(cv_name .eq. cv_name_read) then allocate(cvar3d(i1s:i1e,i2s:i2e,i3s:i3e)) read(i_ic) cvar3d do i3=i3s,i3e do i2=i2s,i2e do i1=i1s,i1e icount=icount+1 x(icount)=cvar3d(i1,i2,i3) end do end do end do deallocate(cvar3d) else write(*,*)" convert_vrbls_to_1d, PROBLEM with cv_name_read=",cv_name_read stop endif else if(cvar_list(j)%ndim.eq.2) then read(i_ic) cv_name_read if(cv_name .eq. cv_name_read) then allocate(cvar2d(i1s:i1e,i2s:i2e)) read(i_ic) cvar2d do i2=i2s,i2e do i1=i1s,i1e icount=icount+1 x(icount)=cvar2d(i1,i2) end do end do deallocate(cvar2d) else write(*,*)" convert_vrbls_to_1d, PROBLEM with cv_name_read=",cv_name_read stop endif else if(cvar_list(j)%ndim.eq.1) then read(i_ic) cv_name_read if(cv_name .eq. cv_name_read) then allocate(cvar1d(i1s:i1e)) read(i_ic) cvar1d do i1=i1s,i1e icount=icount+1 x(icount)=cvar1d(i1) end do deallocate(cvar1d) else write(*,*)" convert_vrbls_to_1d, PROBLEM with cv_name_read=",cv_name_read stop endif else write(*,*) "IC DOES NOT HAVE APPROPRIATE ndim=",cvar_list(j)%ndim end if end if !-- empirical model parameters if(cvar(i)%param) then cv_name=cvar(i)%name read(i_param) cv_name_read if(cv_name .eq. cv_name_read) then read(i_param) cvarparm icount=icount+1 x(icount)=cvarparm else write(*,*)" convert_vrbls_to_1d, PROBLEM with cv_name_read=",cv_name_read stop endif end if !-- model bias if(cvar(i)%bias) then cv_name=cvar(i)%name do nbias=1,num_bias unitbfile=unitbias(nbias) if(cvar_list(j)%ndim.eq.4) then read(unitbfile) cv_name_read if(cv_name .eq. cv_name_read) then allocate(cvar4d(i1s:i1e,i2s:i2e,i3s:i3e,i4s:i4e)) read(unitbfile) cvar4d do i4=i4s,i4e do i3=i3s,i3e do i2=i2s,i2e do i1=i1s,i1e icount=icount+1 x(icount)=cvar4d(i1,i2,i3,i4) end do end do end do end do deallocate(cvar4d) else write(*,*)" convert_vrbls_to_1d, PROBLEM with cv_name_read=",cv_name_read stop endif else if(cvar_list(j)%ndim.eq.3) then read(unitbfile) cv_name_read if(cv_name .eq. cv_name_read) then allocate(cvar3d(i1s:i1e,i2s:i2e,i3s:i3e)) read(unitbfile) cvar3d do i3=i3s,i3e do i2=i2s,i2e do i1=i1s,i1e icount=icount+1 x(icount)=cvar3d(i1,i2,i3) end do end do end do deallocate(cvar3d) else write(*,*)" convert_vrbls_to_1d, PROBLEM with cv_name_read=",cv_name_read stop endif else if(cvar_list(j)%ndim.eq.2) then read(unitbfile) cv_name_read if(cv_name .eq. cv_name_read) then allocate(cvar2d(i1s:i1e,i2s:i2e)) read(unitbfile) cvar2d do i2=i2s,i2e do i1=i1s,i1e icount=icount+1 x(icount)=cvar2d(i1,i2) end do end do deallocate(cvar2d) else write(*,*)" convert_vrbls_to_1d, PROBLEM with cv_name_read=",cv_name_read stop endif else if(cvar_list(j)%ndim.eq.1) then read(unitbfile) cv_name_read if(cv_name .eq. cv_name_read) then allocate(cvar1d(i1s:i1e)) read(unitbfile) cvar1d do i1=i1s,i1e icount=icount+1 x(icount)=cvar1d(i1) end do deallocate(cvar1d) else write(*,*)" convert_vrbls_to_1d, PROBLEM with cv_name_read=",cv_name_read stop endif else write(*,*) "BIAS DOES NOT HAVE APPROPRIATE ndim=",cvar_list(j)%ndim end if end do end if !---------------------------------------------- end if end do end do !---------------------------------------------- if(icount.ne.idim_1d) then write(*,*) " convert_vrbls_to_1d, PROBLEM with icount=",icount, & " idim_1d=",idim_1d stop endif if(open_ic) then CLOSE(i_ic,status='KEEP') end if if(open_param) then CLOSE(i_param,status='KEEP') end if if(open_bias) then do nbias=1,num_bias unitbfile=unitbias(nbias) CLOSE(unitbfile,status='KEEP') end do end if !---------write 1d file------------------------- rewind 21 WRITE(21) idim_1d WRITE(21) x(1:idim_1d) deallocate(x) write(*,*) " end convert_vrbls_to_1d" end program convert_vrbls_to_1d