module mod_restart ! --- Removed old stuff used by the old file types contains c --- ---------------------------------------------- c --- Read hycom model state from file. c --- Now the only option is hycom-style .[ab] files c --- ---------------------------------------------- subroutine read_restart_mem(rt,nstep0,dtime0) use mod_xc use mod_year_info use mod_hycom_nersc implicit none type(year_info), intent(in) :: rt integer, intent(out) :: nstep0 real*8, intent(out) :: dtime0 c character(len=80) :: filename logical ex integer iday, iyear, ihour include 'common_blocks.h' c filename=restartfile(rt) call forday(dtime_start,yrflag,iyear,iday,ihour) if (mnproc==1) print *,'read_restart:',iyear,iday,ihour c c --- Check for existence. Stop inquire(file=trim(filename)//'.a',exist=ex) if (.not.ex) then if(mnproc==1) & write(lp,*)' File '//trim(filename)//'.[ab]'// & ' does not exist' call xcstop('(m_read_restart:read_restart_mem)') stop '(m_read_restart:read_restart_mem)' end if c c --- use hycom restart routine. Modify restart filename flnmrsi=trim(filename) if (mnproc==1) write(lp,'(a)',advance='yes') 'reading: '// & trim(filename)//'.[ab]' call restart_in(nstep0,dtime0, & trim(flnmrsi)//'.a', trim(flnmrsi)//'.b') if (mnproc==1) then write(lp,'(a,f10.2)')'read_restart:Restart day is ',dtime0 write(lp,'(a,i10)') 'read_restart:nstep is ',nstep0 write(lp,'(a)')'read_restart:rt is '//rt%cyy//' '//rt%cmm & //' '//rt%cdm end if end subroutine read_restart_mem c --- Read of old ice format files. real*8, one record for each member. c --- Should be made obsolete some time in the future. (See c --- SINGLE_RESTART flags) function read_restart_ice(rt) use mod_xc use mod_hycom_nersc use mod_year_info use mod_common_ice implicit none logical read_restart_ice type(year_info) , intent(in) :: rt c real, dimension(itdm,jtdm) :: & lficem,lhicem,lhsnwm,lticem,ltsrfm,liceU,liceV real*8, dimension(itdm,jtdm) :: ! Hard-coded real*8 for file IO & io_ficem,io_hicem,io_hsnwm,io_ticem,io_tsrfm,io_iceU,io_iceV character(len=27) icename logical ex integer i,j,iostat real x(10) #if defined (SINGLE_RESTART) && defined (SINGLE_RESTART_ONLY) c --- In this case this routine is entirely replaced by the new c --- IO read_restart_ice=read_restart_ice_ab(rt) return #endif c c --- Prepare to read old ice filetype read_restart_ice=.true. icename=fileice(rt) if(mnproc==1) write(lp,'(a,i4)',advance='yes') & 'reading: '//trim(icename)// & ' record=',imem inquire(file=icename,exist=ex) if (ex) then inquire(iolength=j) & io_ficem,io_hicem,io_hsnwm,io_ticem,io_tsrfm !,iceU,iceV open(10,file=icename,status='old',form='unformatted', & access='direct',recl=j) iceU=0.0; iceV=0.0 io_iceU=0.0; io_iceV=0.0 read(10,rec=imem,err=200,iostat=iostat)io_ficem,io_hicem, & io_hsnwm,io_ticem,io_tsrfm !,liceU,liceV 200 continue close(10) c --- Bail on error if (iostat/=0) then if (mnproc==1) then write(lp,*) 'An error occured while reading '//trim(icename) write(lp,*) 'IOSTAT is :',iostat end if read_restart_ice=.false. call xcstop('(read_restart_ice)') stop '(read_restart_ice)' c --- Spread to all nodes else lficem=io_ficem lhicem=io_hicem lhsnwm=io_hsnwm lticem=io_ticem ltsrfm=io_tsrfm call xcaput(lficem,ficem,0) call xcaput(lhicem,hicem,0) call xcaput(lhsnwm,hsnwm,0) call xcaput(lticem,ticem,0) call xcaput(ltsrfm,tsrfm,0) end if c --- File not found - return with read flag== false else if (mnproc==1) then write(lp,*) 'Restart file for ICE does not exist.' write(lp,*) 'I continue with fields from iniice' end if read_restart_ice=.false. endif c end function read_restart_ice !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! The following is for using existing restart files for NERSC fields as well #if defined (SINGLE_RESTART) ! KAL - with the advent of ice types, fy fraction and ice age, ! KAL - it is finally time to drop the old restart file setup for ! KAL - ice variables. The .ab files are much more flexible for ! KAL - future changes logical function read_restart_ice_ab(rt) use mod_xc use mod_za use mod_common_ice use mod_year_info use mod_hycom_nersc implicit none type(year_info) , intent(in) :: rt character filebase*80 integer :: ierr(5) read_restart_ice_ab=.true. filebase=restartfile(rt) if(mnproc==1) write(lp,'(a)',advance='yes') & 'read_restart_ice_ab: reading '//trim(filebase)//'.[ab]' ! Retrieve record indexes for the variables call restart_getfield(filebase,'ficem',0,1,ficem,ierr(1)) call restart_getfield(filebase,'hicem',0,1,hicem,ierr(2)) call restart_getfield(filebase,'hsnwm',0,1,hsnwm,ierr(3)) call restart_getfield(filebase,'tsrfm',0,1,tsrfm,ierr(4)) call restart_getfield(filebase,'ticem',0,1,ticem,ierr(5)) ! These are essential fields so we halt if they are not found if (any(ierr(1:5)/=0)) then read_restart_ice_ab=.false. if (mnproc==1) write (lp,'(a)') 'An error occured when '// & ' reading the ice fields' call xcstop('(read_restart_ice_ab') stop '(read_restart_ice_ab' end if end function read_restart_ice_ab #endif /*SINGLE_RESTART*/ c c c --- ================================================================ c --- ================================================================ c --- ----------- Routines for saving restart files ---------------- c --- ================================================================ c --- ================================================================ c c c --- Read of old ice format files. real*8, one record for each member. c --- Should be made obsolete some time in the futore subroutine save_restart_mem(rt,nstep0,dtime0) use mod_year_info use mod_xc use mod_za implicit none type(year_info), intent(in) :: rt integer, intent(in) :: nstep0 real*8, intent(in) :: dtime0 c character(len=80) filename include 'common_blocks.h' c c --- Use hycom restart routine. Modify restart filename filename=trim(restartfile(rt)) flnmrso=trim(filename) if (mnproc==1) write(lp,*) 'Dumping to file '// & trim(flnmrso)//'.[ab]' call restart_out(nstep0,dtime0, & trim(flnmrso),trim(flnmrso),.true.) c c --- Hmm .. not closed automatically ... c call zaiocl(12) c if (mnproc==1) then c close(12) c end if end subroutine save_restart_mem c c c function save_restart_ice(rt) use mod_xc use mod_year_info use mod_common_ice use mod_hycom_nersc implicit none type(year_info), intent(in) :: rt c real, dimension(itdm,jtdm) :: & tficem,thicem,thsnwm,tticem,ttsrfm,ticeU,ticeV real*8, dimension(itdm,jtdm) :: ! Hard-coded real*8 for file IO & io_ficem,io_hicem,io_hsnwm,io_ticem,io_tsrfm,io_iceU,io_iceV logical :: save_restart_ice character(len=27) icename integer i,j, iostat, ioproc real :: a(1) #if defined (SINGLE_RESTART) /* We always dump when this flag is set */ save_restart_ice=save_restart_ice_ab(rt) #if defined (SINGLE_RESTART_ONLY) /* Short-circuit when this flag is set */ return #endif /* SINGLE_RESTART_ONLY */ #endif /* SINGLE_RESTART */ ioproc=1 ! NB get stop - signals valid for MPI runs as well ! ! Put ice data into non-tiled arrays call xcaget(tficem,ficem,0) ; io_ficem=tficem call xcaget(thicem,hicem,0) ; io_hicem=thicem call xcaget(thsnwm,hsnwm,0) ; io_hsnwm=thsnwm call xcaget(tticem,ticem,0) ; io_ticem=tticem call xcaget(ttsrfm,tsrfm,0) ; io_tsrfm=ttsrfm call xcaget(ticeU ,iceU ,0) ; io_iceu =ticeu call xcaget(ticeV ,iceV ,0) ; io_icev =ticev ! Only one node is alloved to access this file (only important for MPI) save_restart_ice=.true. if (mnproc==ioproc) then icename=fileice(rt) write(lp,'(a,i4)',advance='yes')'Saving : '// & trim(icename)//' record=',imem !inquire(iolength=j)tficem,thicem,thsnwm,tticem,ttsrfm !,ticeU,ticeV inquire(iolength=j) & io_ficem,io_hicem,io_hsnwm,io_ticem,io_tsrfm !,ticeU,ticeV !print *,'iolength=',j ! Not important open(10,file=icename,status='unknown',form='unformatted', & access='direct',recl=j) write(10,rec=imem,err=200,iostat=iostat)io_ficem,io_hicem, & io_hsnwm,io_ticem,io_tsrfm !,io_iceU,io_iceV 200 continue close(10) if (iostat==0) then !write(lp,*) ' ICE done' save_restart_ice=.true. else write(lp,'(a,i4)') & 'An Error encountered while writing record ',imem save_restart_ice=.false. write(lp,'(a,i4)') 'IOSTAT is :',iostat end if end if ! KAL : Should communicate result to all processes in MPI... if (save_restart_ice) a(1)=1. call xcastr(a,1); save_restart_ice=nint(a(1))==1 a(1)=iostat call xcastr(a,1); iostat=int(a(1)) ! KAL - new: bail out on save errors.. Prevent disaster in the ! making if (iostat/=0) then if (mnproc==1) then write(lp,*) 'Exiting on iostat save errors...' write(lp,*) 'IOSTAT is ',iostat end if call xcstop('(save_restart_ice)') stop '(save_restart_ice)' end if end function save_restart_ice #if defined (SINGLE_RESTART) ! KAL - with the advent of ice types, fy fraction and ice age, ! KAL - it is finally time to drop the old restart file setup for ! KAL - ice variables. The .ab files are much more flexible for ! KAL - future changes. This version appends everything ! KAL - to the HYCOM restart file logical function save_restart_ice_ab(rt) use mod_xc use mod_za use mod_common_ice use mod_year_info use mod_hycom_nersc implicit none type(year_info) , intent(in) :: rt character filebase*80 integer :: ierr save_restart_ice_ab=.true. filebase=trim(restartfile(rt)) if (mnproc==1) then write(lp,'(a)',advance='yes')'save_restart_ice_ab: Saving '// & trim(filebase)//'.[ab]' end if call restart_appendfield(filebase,'ficem ',0,1,ficem,ierr) call restart_appendfield(filebase,'hicem ',0,1,hicem,ierr) call restart_appendfield(filebase,'hsnwm ',0,1,hsnwm,ierr) call restart_appendfield(filebase,'tsrfm ',0,1,tsrfm,ierr) call restart_appendfield(filebase,'ticem ',0,1,ticem,ierr) #if defined (TEST_ICE_AGE) call restart_appendfield(filebase,'fy_frac ',0,1,fy_frac,ierr) call restart_appendfield(filebase,'fy_age ',0,1,fy_age ,ierr) call restart_appendfield(filebase,'rdg_frac',0,1,rdg_frac,ierr) #endif if (ierr/=0) save_restart_ice_ab=.false. end function save_restart_ice_ab #endif /* SINGLE_RESTART */ c c c --- Reorg of random forcing - it is now appended to hycom restart c --- files subroutine read_restart_rand_ab(rt) use mod_xc use mod_random_forcing use mod_year_info implicit none type(year_info) , intent(in) :: rt c character filebase*80 integer :: ierr(10) c filebase=trim(restartfile(rt)) if (mnproc==1) then write(lp,'(a)')'read_restart_rand_ab reading ' & //trim(filebase)//'.[ab]' end if c c --- Retrieve record indexes for the variables call restart_getfield(filebase,'rf_slp' ,0,1,ran%slp ,ierr( 1)) call restart_getfield(filebase,'rf_taux' ,0,1,ran%taux ,ierr( 2)) call restart_getfield(filebase,'rf_tauy' ,0,1,ran%tauy ,ierr( 3)) call restart_getfield(filebase,'rf_wspd' ,0,1,ran%wndspd,ierr( 4)) call restart_getfield(filebase,'rf_tair' ,0,1,ran%airtmp,ierr( 5)) call restart_getfield(filebase,'rf_rlhum',0,1,ran%relhum,ierr( 6)) call restart_getfield(filebase,'rf_cloud',0,1,ran%clouds,ierr( 7)) call restart_getfield(filebase,'rf_prcp' ,0,1,ran%precip,ierr( 8)) call restart_getfield(filebase,'rf_sss' ,0,1,ran%sss, ierr( 9)) call restart_getfield(filebase,'rf_sst' ,0,1,ran%sst, ierr(10)) c c --- These are not essential fields so we continue if they are not found if (any(ierr(1:10)/=0)) then if (mnproc==1) write (lp,'(a)') 'An error occured when '// & ' reading the random fields' end if end subroutine read_restart_rand_ab c subroutine save_restart_rand_ab(rt) use mod_xc use mod_random_forcing use mod_year_info implicit none type(year_info) , intent(in) :: rt c character(len=80) :: filebase integer :: ierr c filebase=trim(restartfile(rt)) if (mnproc==1) then write(lp,'(a)',advance='yes') & 'save_restart_rand_ab: saving '// & trim(filebase)//'.[ab]' end if call restart_appendfield(filebase,'rf_slp ',0,1,ran%slp ,ierr) call restart_appendfield(filebase,'rf_taux ',0,1,ran%taux ,ierr) call restart_appendfield(filebase,'rf_tauy ',0,1,ran%tauy ,ierr) call restart_appendfield(filebase,'rf_wspd ',0,1,ran%wndspd,ierr) call restart_appendfield(filebase,'rf_tair ',0,1,ran%airtmp,ierr) call restart_appendfield(filebase,'rf_rlhum',0,1,ran%relhum,ierr) call restart_appendfield(filebase,'rf_cloud',0,1,ran%clouds,ierr) call restart_appendfield(filebase,'rf_prcp ',0,1,ran%precip,ierr) call restart_appendfield(filebase,'rf_sss ',0,1,ran%sss ,ierr) call restart_appendfield(filebase,'rf_sst ',0,1,ran%sst ,ierr) !if (ierr/=0) save_restart_rand_ab=.false. end subroutine save_restart_rand_ab c c c --- ================================================================ c --- ================================================================ c --- ---------------- Auxillary routines -------------------------- c --- ================================================================ c --- ================================================================ c c ! Base name of restart file function restartfile(rt) use mod_year_info use mod_hycom_nersc implicit none character(len=80) restartfile type(year_info) rt character(len=3) :: cmem integer indx restartfile='' restartfile(1:3)=rungen(1:3) restartfile(4:10)='restart' restartfile(11:14)=rt%cyy(1:4) restartfile(15:15)='_' restartfile(16:18)=rt%cdd(1:3) restartfile(19:19)='_' restartfile(20:21)=rt%chh(1:2) ! If imem > 1 - append member index ... if (ensflag) then write(cmem,'(i3.3)') imem restartfile=restartfile(1:len_trim(restartfile)) & //'_mem'//cmem end if end function restartfile c function fileice(rt) use mod_year_info use mod_hycom_nersc implicit none character(len=27) fileice type(year_info) rt fileice(1:3)=rungen(1:3) fileice(4:10)='restart' fileice(11:14)=rt%cyy(1:4) fileice(15:15)='_' fileice(16:18)=rt%cdd(1:3) fileice(19:19)='_' fileice(20:21)=rt%chh(1:2) fileice(22:27)='ICE.uf' end function fileice c c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! c This retrieves the field corresponding to variable name, layer index and c time level. Calls restart_getindex first c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine restart_getfield(filebase,varname,ilayer,itime, & field,ierr) use mod_za implicit none character(len=*), intent(in) :: filebase, varname integer, intent(in) :: ilayer, itime real, intent(out) :: & field(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) integer, intent(out) :: ierr integer :: indx,k real :: bmin, bmax, amin, amax integer, parameter :: nop=711 ierr = 0 call restart_getindex(filebase,varname,ilayer,itime,indx, & bmin,bmax) if (indx<=0) then if (mnproc==1) & print '(a,2i5)','restart_getfield: Can not find field '// & trim(varname),ilayer, itime ierr=-1 return end if if (mnproc==1) write(lp,'(a,i4,a,2i4,1x,a)'), & 'restart_getfield: index is ',indx,' for ',ilayer,itime,varname c --- Safe to open call zaiopf(filebase(1:len_trim(filebase))//'.a','old', nop) c c --- Skip to indx "indx" and read do k=1,indx-1 call zaiosk(nop) end do call zaiord(field, ip,.false., amin,amax, nop) c if (abs(amin-bmin).gt.abs(bmin)*1.e-4 .or. & abs(amax-bmax).gt.abs(bmax)*1.e-4 ) then if (mnproc.eq.1) then write(lp,'(/ a / a,2i3 / a,2i3 / a,1p3e14.6 / a,1p3e14.6 /)') & 'error - .a and .b files not consistent:', & 'iunit,indx = ',711,indx, & 'vname,itime,ilayer = '//trim(varname),itime,ilayer, & '.a,.b min = ',amin,bmin,amin-bmin, & '.a,.b max = ',amax,bmax,amax-bmax endif !1st tile ierr=-1 c --- Deemed a critical error - something is way wrong call xcstop('(restart_getfield)') stop '(restart_getfield)' endif call zaiocl(nop) end subroutine c c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! c This appends the field with varname, ilayer, itime to the file with base c name "filebase". Retrieves last index of .a-file first c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine restart_appendfield(filebase,varname,ilayer,itime, & field,ierr) use mod_za implicit none character(len=*), intent(in) :: filebase character(len=8), intent(in) :: varname integer, intent(in) :: ilayer, itime real, intent(inout) :: & field(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) integer, intent(out) :: ierr real :: xmin, xmax integer :: indx,k integer, parameter :: nop=711 ierr=0 ! Do something more meaningful later on indx=restart_lastindex(trim(filebase)) call xcsync(flush_lp) if (mnproc==1) print *,indx call zaiopf(filebase(1:len_trim(filebase))//'.a','unknown', nop) if (mnproc==1) then open (unit=nop,file=filebase(1:len_trim(filebase))//'.b', & status='unknown',action='readwrite',form='formatted') end if if (mnproc==1) write(lp,'(a,i4,a,2i4,1x,a)'), & 'restart_appendfield: index is ',indx, ' for ', & ilayer,itime,varname c c --- skip first two lines + indx lines do k=1,2+indx if (mnproc==1) read(nop,*) end do do k=1,indx call zaiosk(nop) end do c call zaiowr(field(1-nbdy,1-nbdy),ip,.false., & xmin,xmax, nop, .false.) if (mnproc==1) write(nop,4100) varname,ilayer,itime,xmin,xmax if (mnproc==1) close(nop) call zaiocl(nop) 4100 format(a,': layer,tlevel,range = ',i3,i3,2x,1p2e16.7) end subroutine c c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! c This retrieves the number of the last index in .ab files. Input is file c base (without .a or .b ending) c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! integer function restart_lastindex(filebase) use mod_za implicit none character(len=*), intent(in) :: filebase integer :: i1,i2,k,ios, indx character(len=8) :: char8 real :: xmin, xmax, rli integer, parameter :: nop=711 integer :: iunitb, iunita restart_lastindex=-1 rli=-1. if (mnproc==1) then open (unit=nop,file=filebase(1:len_trim(filebase))//'.b', & status='unknown',action='read',form='formatted') ! Skip two first lines read(nop,*,iostat=ios) read(nop,*,iostat=ios) if (ios/=0) then close(nop) restart_lastindex=-1 return end if ! Read until EOF ios=0 indx=0 do while (ios==0) read(nop,4100,iostat=ios) char8,i1,i2, xmin, xmax indx=indx+1 end do close(nop) restart_lastindex=indx-1 rli=restart_lastindex end if call xcmaxr(rli) ; restart_lastindex=rli 4100 format(a,': layer,tlevel,range = ',i3,i3,2x,1p2e16.7) end function restart_lastindex c c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! c This retrieves the .ab-index corresponding to variable name, layer index and c time level. One task reads. c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine restart_getindex(filebase,varname,ilayer,itime,fldindx, & bmin,bmax) use mod_za implicit none character(len=*), intent(in) :: filebase, varname integer, intent(in) :: ilayer, itime integer, intent(out) :: fldindx real, intent(out) :: bmin, bmax integer :: i1,i2,k,ios, indx character(len=8) :: char8 real :: xmin, xmax, rfi logical :: match integer, parameter :: nop=711 fldindx=-1 ; rfi=-1. if (mnproc==1) then open (unit=nop,file=filebase(1:len_trim(filebase))//'.b', & status='unknown',action='read',form='formatted') c --- Skip two first lines (header) read(nop,*,iostat=ios) read(nop,*,iostat=ios) if (ios/=0) then close(nop) return end if c --- Read until match ios=0 indx=0 match=.false. do while (ios==0) read(nop,4100,iostat=ios) char8,i1,i2, xmin, xmax indx=indx+1 if (trim(char8)==trim(varname) .and. i1==ilayer .and. & i2==itime .and. ios==0) then fldindx=indx; rfi=indx; bmin=xmin bmax=xmax match=.true. end if end do close(nop) end if ! mnproc==1 call xcmaxr(rfi) ; fldindx=rfi c if (mnproc==1) write(lp,'(a,i4,a,2i4,1x,a)'), & c 'restart_getindex is ',fldindx, ' for ',ilayer,itime,varname 4100 format(a,': layer,tlevel,range = ',i3,i3,2x,1p2e16.7) end subroutine restart_getindex c end module mod_restart