subroutine getartype(flnm,artype) use mod_plot ! HYCOM plot array interface use mod_za ! HYCOM array I/O interface implicit none c character flnm*(*) integer artype c c --- read artype from archive file. c --- artype== 1 for normal archive files c --- artype==-1 for normal archive files with p-vel c --- artype== 2 for mean archive files c --- artype==-2 for mean archive files with p-vel c --- artype== 3 for stddev archive files c --- artype== 4 for diff archive files c character cline*80 integer l,ni c data ni/14/ c l = len_trim(flnm) c if (flnm(l-1:l).eq.'.a' .or. flnm(l-1:l).eq.'.b') then open (unit=ni,file=flnm(1:l-2)//'.b',form='formatted', & status='old',action='read') read( ni,'(a80/a80/a80/a80)') ctitle read( ni,'(a)') cline ! iversn read( ni,'(a)') cline ! iexpt read( ni,'(a)') cline ! yrflag read( ni,'(a)') cline ! idm read( ni,'(a)') cline ! jdm c read( ni,'(a)') cline if (cline(25:28).eq.'mean') then artype = 2 elseif (cline(25:28).eq.'std.') then artype = 3 elseif (cline(25:28).eq.'diff') then artype = 4 else artype = 1 endif if (cline(1:7).eq.'field_p') then artype = -artype endif close(ni) else artype = 1 endif return end subroutine getdat(flnm,time,artype,initl,lsteric,icegln,trcout, & iexpt,iversn,yrflag,kkin) use mod_plot ! HYCOM plot array interface use mod_za ! HYCOM array I/O interface implicit none c character flnm*(*) double precision time(3) logical initl,lsteric,icegln,trcout integer artype,iexpt,iversn,yrflag,kkin c c --- read model fields and extract portion of global fields. c integer l c real, allocatable :: work(:,:) character*240 :: cfile c allocate( work(idm,jdm) ) c l = len_trim(flnm) c if (flnm(l-1:l).eq.'.a' .or. flnm(l-1:l).eq.'.b') then c --- HYCOM 2.0 array I/O archive file. cfile = ' ' call getenv('ARCHVS',cfile) if (cfile.eq.' ') then c ---- standard archive call getdata( flnm,time,artype,.true., & initl,lsteric,icegln, & iexpt,iversn,yrflag,kkin, work) else c ---- partial surface archive call getdata1(flnm,time,artype,.true., & initl,lsteric,icegln, & iexpt,iversn,yrflag,kkin, work) endif elseif (flnm(l-3:l).eq.'.txt') then c --- HYCOM 2.0 text profile file call getdatt(flnm,time(1), & initl, & iexpt,iversn,yrflag,kkin, work) lsteric = .false. icegln = .false. trcout = .false. time(2) = time(1) time(3) = time(1) artype = 1 sigver = 0 else write(lp,*) write(lp,*) "error in getdatb - not an .[ab] file ", & trim(flnm) write(lp,*) call flush(lp) stop endif deallocate( work ) return end subroutine getdats(flnm,time,artype,initl,lsteric,icegln,trcout, & iexpt,iversn,yrflag,kkin) use mod_plot ! HYCOM plot array interface use mod_za ! HYCOM array I/O interface implicit none c character flnm*(*) double precision time(3) logical initl,lsteric,icegln,trcout integer artype,iexpt,iversn,yrflag,kkin c c --- read model fields and extract portion of global fields. c --- spectial version for HYCOM std input and "3z" output. c integer l c real, allocatable :: work(:,:) c allocate( work(idm,jdm) ) c l = len_trim(flnm) c if (flnm(l-1:l).eq.'.a' .or. flnm(l-1:l).eq.'.b') then c --- HYCOM 2.0 array I/O archive file. call getdatas(flnm,time,artype,.true., & initl,lsteric,icegln, & iexpt,iversn,yrflag,kkin, work) sigver = 0 else write(lp,*) write(lp,*) "error in getdatb - not an .[ab] file ", & trim(flnm) write(lp,*) call flush(lp) stop endif deallocate( work ) return end subroutine getdatb(flnm,time,artype,initl,lsteric,icegln,trcout, & iexpt,iversn,yrflag,kkin) use mod_plot ! HYCOM plot array interface use mod_za ! HYCOM array I/O interface implicit none c character flnm*(*) double precision time(3) logical initl,lsteric,icegln,trcout integer artype,iexpt,iversn,yrflag,kkin c c --- read model fields and extract portion of global fields. c --- ignore ".a" vs ".b" range mismatches. c integer l real, allocatable :: work(:,:) character*240 :: cfile c allocate( work(idm,jdm) ) c l = len_trim(flnm) c if (flnm(l-1:l).eq.'.a' .or. flnm(l-1:l).eq.'.b') then c --- HYCOM 2.0 array I/O archive file. cfile = ' ' call getenv('ARCHVS',cfile) if (cfile.eq.' ') then c ---- standard archive call getdata( flnm,time,artype,.false., & initl,lsteric,icegln, & iexpt,iversn,yrflag,kkin, work) else c ---- partial surface archive call getdata1(flnm,time,artype,.false., & initl,lsteric,icegln, & iexpt,iversn,yrflag,kkin, work) endif else write(lp,*) write(lp,*) "error in getdatb - not an .[ab] file ", & trim(flnm) write(lp,*) call flush(lp) stop endif deallocate( work ) return end subroutine getdata(flnm,time,artype,lrange,initl,lsteric,icegln, & iexpt,iversn,yrflag,kkin, work) use mod_plot ! HYCOM plot array interface use mod_za ! HYCOM array I/O interface c character flnm*(*) double precision time(3) logical lrange,initl,lsteric,icegln integer artype,iexpt,iversn,yrflag,kkin real work(idm,jdm) c c --- read model fields and extract portion of global fields. c --- HYCOM 2.0 and 2.2 array I/O archive file. c --- (no time-averaged fluxes in this version) c character cline*80 character preambl(5)*79 character cvarin*6 real hminb,hmaxb integer i,j,ios,l,k,ktr,ntr logical nodens,lmix,lke double precision timedum c data ni/14/ c l = len_trim(flnm) open (unit=ni,file=flnm(1:l-2)//'.b',form='formatted', & status='old',action='read') call zaiopf(flnm(1:l-2)//'.a','old', ni) c read( ni,'(a80/a80/a80/a80)') ctitle write(lp,'(a80/a80/a80/a80)') ctitle read( ni,*) iversn,cvarin write(lp,*) cvarin,' = ',iversn if (cvarin.ne.'iversn') then write(lp,*) write(lp,*) 'error in getdat - input ',cvarin, & ' but should be iversn' write(lp,*) call flush(lp) stop endif read( ni,*) iexpt,cvarin write(lp,*) cvarin,' = ',iexpt if (cvarin.eq.'jexpt ') then c --- skip jexpt, artype of 4 set below read( ni,*) iexpt,cvarin write(lp,*) cvarin,' = ',iexpt endif if (cvarin.ne.'iexpt ') then write(lp,*) write(lp,*) 'error in getdat - input ',cvarin, & ' but should be iexpt ' write(lp,*) call flush(lp) stop endif read( ni,*) yrflag,cvarin write(lp,*) cvarin,' = ',yrflag if (cvarin.ne.'yrflag') then write(lp,*) write(lp,*) 'error in getdat - input ',cvarin, & ' but should be yrflag' write(lp,*) call flush(lp) stop endif read( ni,*) idmtst,cvarin write(lp,*) cvarin,' = ',idmtst if (cvarin.ne.'idm ') then write(lp,*) write(lp,*) 'error in getdat - input ',cvarin, & ' but should be idm ' write(lp,*) call flush(lp) stop endif read( ni,*) jdmtst,cvarin write(lp,*) cvarin,' = ',jdmtst if (cvarin.ne.'jdm ') then write(lp,*) write(lp,*) 'error in getdat - input ',cvarin, & ' but should be jdm ' write(lp,*) call flush(lp) stop endif c if (idmtst.ne.idm .or. jdmtst.ne.jdm) then write(lp,*) write(lp,*) 'error in getdat - input idm,jdm', & ' not consistent with parameters' write(lp,*) 'idm,jdm = ',idm, jdm, ' (REGION.h)' write(lp,*) 'idm,jdm = ',idmtst,jdmtst,' (input)' write(lp,*) call flush(lp) stop endif c c --- artype== 1 for normal archive files c --- artype==-1 for normal archive files with p-vel c --- artype== 2 for mean archive files c --- artype==-2 for mean archive files with p-vel c --- artype== 3 for stddev archive files c --- artype== 4 for diff archive files c read( ni,'(a)') cline write(lp,'(a)') cline(1:len_trim(cline)) if (cline(25:28).eq.'mean') then artype = 2 elseif (cline(25:28).eq.'std.') then artype = 3 elseif (cline(25:28).eq.'diff') then artype = 4 else artype = 1 endif if (cline(1:7).eq.'field_p') then artype = -artype endif write(lp,'(a,i2)') 'artype =',artype c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,time(1),layer,thet,hminb,hmaxb nodens = layer.ne.0 !detect version 2.2 normal archive files if (nodens) then sigver = layer thbase = thet else sigver = 0 endif call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & montg,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'montg ' * --- discard montg * write(lp,'("input ",a," into ",a)') cline(1:8),'work ' c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,time(2),layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & srfht,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'srfht ' c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,time(3),layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) lsteric = cline(1:8).eq.'steric ' if (lsteric) then call extrct_p(work,idm,jdm,iorign,jorign, & steric,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'steric ' read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) else steric(:,:) = 0.0 endif loneta = cline(1:8).eq.'oneta ' if (loneta) then call extrct_p(work,idm,jdm,iorign,jorign, & oneta,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'oneta ' read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) if (abs(artype).ge.3) then !std or dif if (.not. allocated(onetas)) then allocate( onetas(ii,jj) ) endif onetas(:,:) = oneta(:,:) write(lp,'("copy ",a," into ",a)') 'oneta ','onetas ' call extrct_p(work,idm,jdm,iorign,jorign, & oneta,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'oneta ' read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) endif !std or dif else oneta(:,:) = 1.0 !not used? endif call extrct_p(work,idm,jdm,iorign,jorign, & surflx,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'surflx ' c call time_hour(time) !reset, assuming time is on the hour write(lp,*) 'time3 = ',time c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) if (cline(1:8).ne.'wtrflx ') then wtrflx(:,:) = 0.0 !updated later else lwtrflx = .true. !output wrtflx if input archive contains it call extrct_p(work,idm,jdm,iorign,jorign, & wtrflx,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'wtrflx ' read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,time(3),layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) endif call extrct_p(work,idm,jdm,iorign,jorign, & salflx,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'salflx ' c surtx(:,:) = 0.0 surty(:,:) = 0.0 c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & dpbl,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'dpbl ' c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & dpmixl,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'dpmixl ' c c --- are there mix fields? read (ni,'(a)',iostat=ios) cline write(lp,'(a)') cline(1:len_trim(cline)) lmix = ios.eq.0 .and. cline(1:8).eq.'tmix ' if (lmix) then i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & tmix,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'tmix ' c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & smix,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'smix ' c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & thmix,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'thmix ' c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .true. ,lrange) call extrct_u(work,idm,jdm,iorign,jorign, & umix,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'umix ' c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .true. ,lrange) call extrct_v(work,idm,jdm,iorign,jorign, & vmix,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'vmix ' c read (ni,'(a)',iostat=ios) cline write(lp,'(a)') cline(1:len_trim(cline)) endif !lmix:else c c --- is there ke? lke = artype.gt.1 .and. ios.eq.0 .and. cline(1:8).eq.'kemix ' if (lke) then ! mean or std. archive with ke if (.not. allocated(kemix)) then allocate( kemix(ii,jj) ) endif if (.not. allocated(kebaro)) then allocate( kebaro(ii,jj) ) endif if (.not. allocated(ke)) then allocate( ke(ii,jj,kkmax) ) endif i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .true. ,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & kemix,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'kemix ' read (ni,'(a)',iostat=ios) cline write(lp,'(a)') cline(1:len_trim(cline)) endif c c --- is there ice? * read (ni,'(a)',iostat=ios) cline * write(lp,'(a)') cline(1:len_trim(cline)) icegln = ios.eq.0 .and. cline(1:8).eq.'covice ' if (icegln) then i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & covice,ii,jj) c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & thkice,ii,jj) c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & temice,ii,jj) c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) else covice(:,:) = 0.0 thkice(:,:) = 0.0 temice(:,:) = 0.0 endif c i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .true. ,lrange) if (artype.ge.0) then call extrct_u(work,idm,jdm,iorign,jorign, & ubaro,ii,jj) else call extrct_p(work,idm,jdm,iorign,jorign, & ubaro,ii,jj) endif !artype>0:else write(lp,'("input ",a," into ",a)') cline(1:8),'ubaro ' c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .true. ,lrange) if (artype.ge.0) then call extrct_v(work,idm,jdm,iorign,jorign, & vbaro,ii,jj) else call extrct_p(work,idm,jdm,iorign,jorign, & vbaro,ii,jj) endif !artype>0:else write(lp,'("input ",a," into ",a)') cline(1:8),'vbaro ' c if (lke) then ! mean or std. archive with ke read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .true. ,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & kebaro,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'kebaro ' endif c kkin=1 do 14 k=1,kk if (k.eq.2) then c --- already input at end of k=1 loop. else read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) endif i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb if (artype.ge.0) then if (cline(1:8).ne.'u-vel. ') then write(lp,*) write(lp,*) 'error in getdat - layer ',k, & ' does not exist (kk= ',kk,')' write(lp,*) call flush(lp) stop endif else if (cline(1:8).ne.'up-vel. ') then write(lp,*) write(lp,*) 'error in getdat - layer ',k, & ' does not exist (kk= ',kk,')' write(lp,*) call flush(lp) stop endif endif call getfld( work, ni, hminb,hmaxb, .true. ,lrange) if (artype.ge.0) then call extrct_u(work,idm,jdm,iorign,jorign, & u(1,1,k),ii,jj) else call extrct_p(work,idm,jdm,iorign,jorign, & u(1,1,k),ii,jj) endif !artype>0:else write(lp,'("input ",a," into ",a,i3)') cline(1:8),'u ',k c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .true. ,lrange) if (artype.ge.0) then call extrct_v(work,idm,jdm,iorign,jorign, & v(1,1,k),ii,jj) else call extrct_p(work,idm,jdm,iorign,jorign, & v(1,1,k),ii,jj) endif !artype>0:else write(lp,'("input ",a," into ",a,i3)') cline(1:8),'v ',k c if (lke) then ! mean or std. archive with ke read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & ke(1,1,k),ii,jj) write(lp,'("input ",a," into ",a,i3)') cline(1:8),'ke ',k endif c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .true., lrange) call extrct_p(work,idm,jdm,iorign,jorign, & dp(1,1,k),ii,jj) write(lp,'("input ",a," into ",a,i3)') cline(1:8),'dp ',k c if (cline(1:8).eq.'mnthknss') then c --- std. thickness. is next, put in dpsd if (.not. allocated(dpsd)) then allocate( dpsd(ii,jj,kkmax) ) endif read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .true., lrange) call extrct_p(work,idm,jdm,iorign,jorign, & dpsd(1,1,k),ii,jj) write(lp,'("input ",a," into ",a,i3)') cline(1:8),'dpsd ',k endif c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & temp(1,1,k),ii,jj) write(lp,'("input ",a," into ",a,i3)') cline(1:8),'temp ',k c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & saln(1,1,k),ii,jj) write(lp,'("input ",a," into ",a,i3)') cline(1:8),'saln ',k c if (k.eq.1 .and. .not.lwtrflx) then do j= 1,jj do i= 1,ii if (saln(i,j,k).lt.2.0**99) then wtrflx(i,j) = salflx(i,j)/max(saln(i,j,k),0.001) endif enddo enddo write(lp,'("conv. ",a," into ",a)') 'salflx ','wtrflx ' endif !not lwtrflx c if (.not. nodens) then read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & th3d(1,1,k),ii,jj) write(lp,'("input ",a," into ",a,i3)') cline(1:8),'th3d ',k else call th3d_p(temp(1,1,k),saln(1,1,k), & th3d(1,1,k),ii,jj, sigver,thbase) write(lp,'(" ",a8,"calculate ",a,i3)') " ",'th3d ',k if (k.eq.1) then tmix(:,:) = temp(:,:,1) smix(:,:) = saln(:,:,1) thmix(:,:) = th3d(:,:,1) umix(:,:) = u(:,:,1) vmix(:,:) = v(:,:,1) write(lp,'("copy ",a," into ",a)') 'temp.1 ','tmix ' write(lp,'("copy ",a," into ",a)') 'saln.1 ','smix ' write(lp,'("copy ",a," into ",a)') 'th3d.1 ','thmix ' write(lp,'("copy ",a," into ",a)') ' u.1 ','umix ' write(lp,'("copy ",a," into ",a)') ' v.1 ','vmix ' endif !k==1 endif !.not.nodens:else c c --- tracers and visc/diff, may be more in archive than processed. c if (k.eq.1) then do ktr= 1,999 read (ni,'(a)',iostat=ios) cline write(lp,'(a)') cline(1:len_trim(cline)) if (ios.ne.0) then write(lp,'(a,f9.5)') 'finished reading data for layer',thet call flush(lp) theta(k)=thet goto 114 ! archive containing only 1 layer elseif (cline(1:8).ne.'tracer ' .and. & cline(1:8).ne.'viscty ' .and. & cline(1:8).ne.'t-diff ' .and. & cline(1:8).ne.'s-diff ' ) then exit !end of tracers and visc/diff else i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) if (ktr.le.ntracr) then call extrct_p(work,idm,jdm,iorign,jorign, & trcr(1,1,k,ktr),ii,jj) write(lp,'("input ",a," into ",a,2i3)') & cline(1:8),'trcr ',k,ktr if (cline(1:8).eq.'tracer ') then itrcr_type = 0 elseif (cline(1:8).eq.'viscty ') then itrcr_type = 1 elseif (cline(1:8).eq.'t-diff ') then itrcr_type = 2 elseif (cline(1:8).eq.'s-diff ') then itrcr_type = 3 endif endif endif enddo !ktr ntr=ktr-1 if (ntracr.gt.ntr) then write(lp,*) write(lp,*) 'error in getdat - fewer tracers than requested' write(lp,*) call flush(lp) stop endif else !k.gt.1 do ktr= 1,ntr read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) if (ktr.le.ntracr) then call extrct_p(work,idm,jdm,iorign,jorign, & trcr(1,1,k,ktr),ii,jj) write(lp,'("input ",a," into ",a,2i3)') & cline(1:8),'trcr ',k,ktr endif enddo !ktr endif !tracers+visc/diff c ccc write(lp,'(a,i4)') 'shown below: density in layer',k ccc call zebra(th3d(1,1,k),ii,ii1,jj1) c write(lp,'(a,f9.5)') 'finished reading data for layer',thet call flush(lp) theta(k)=thet 14 continue kkin=kk 114 continue c close( unit=ni) call zaiocl(ni) write(lp,'(a)') 'closed archive file' call flush(lp) c if (initl) then c --- acquire basin depths and land/sea mask call getdepth(work) end if c * write(lp,'(a)') 'shown below: sea surface height' * call zebra(srfht,ii,ii1,jj1) * call flush(lp) c return c c --- unexpected end of file 6 continue write (lp,*) '***** unexpected end of archive file *****' call flush(lp) stop '(e-o-f)' end subroutine getdata1(flnm,time,artype,lrange,initl,lsteric,icegln, & iexpt,iversn,yrflag,kkin, work) use mod_plot ! HYCOM plot array interface use mod_za ! HYCOM array I/O interface c character flnm*(*) double precision time(3) logical lrange,initl,lsteric,icegln integer artype,iexpt,iversn,yrflag,kkin real work(idm,jdm) c c --- read model fields and extract portion of global fields. c --- HYCOM 2.0 and 2.2 array I/O archive file. c --- (no time-averaged fluxes in this version) c --- version for partial surface archives c character cline*80 character preambl(5)*79 character cvarin*6 real hminb,hmaxb logical nodens integer i,j,ios,l,k,ktr,ntr,nvar c integer, parameter :: nfields=20 !no. fields in surface archive logical :: l_arch(nfields) !field output flags character*6 :: c_arch(nfields) !field names (archs.input) character*8 :: c_arc8(nfields) !field names (archive file) character*240 :: cfile c data ni/14/ c c --- list of field names c c_arc8( 1) = 'montg1 ' c_arc8( 2) = 'srfhgt ' c_arc8( 3) = 'steric ' c_arc8( 4) = 'surflx ' c_arc8( 5) = 'wtrflx ' !used to be 'salflx ' c_arc8( 6) = 'bl_dpth ' c_arc8( 7) = 'mix_dpth' c_arc8( 8) = 'covice ' c_arc8( 9) = 'thkice ' c_arc8(10) = 'temice ' c_arc8(11) = 'u_btrop ' c_arc8(12) = 'v_btrop ' c_arc8(13) = 'u-vel. ' c_arc8(14) = 'v-vel. ' c_arc8(15) = 'thknss ' c_arc8(16) = 'temp ' c_arc8(17) = 'salin ' c_arc8(18) = 'salflx ' !after wtrflx c_arc8(19) = 'surtx ' c_arc8(20) = 'surty ' c c --- list of field names, 6 character versions of 8 character names c do k= 1,nfields c_arch(k) = c_arc8(k)(1:6) enddo c_arch( 6) = 'bldpth' c_arch( 7) = 'mldpth' c_arch(11) = 'ubtrop' c_arch(12) = 'vbtrop' c c --- read in archvs.input. c call getenv('ARCHVS',cfile) open(unit=99,file=cfile) do k= 1,4 call blkinl_99(l_arch(k),c_arch(k)) enddo c --- wtrflx or salflx? call blkinl2_99(l_arch(5),nvar,c_arch(5),c_arch(18)) if (nvar.eq.1) then !latest version, 20 fields do k= 6,nfields call blkinl_99(l_arch(k),c_arch(k)) enddo else !old version, no wtrflx and so only 19 fields do k= 6,17 call blkinl_99(l_arch(k),c_arch(k)) enddo l_arch(18) = l_arch(5) l_arch( 5) = .false. !no wtrflx do k= 19,20 call blkinl_99(l_arch(k),c_arch(k)) enddo endif close (unit=99) c l = len_trim(flnm) open (unit=ni,file=flnm(1:l-2)//'.b',form='formatted', & status='old',action='read') call zaiopf(flnm(1:l-2)//'.a','old', ni) c read( ni,'(a80/a80/a80/a80)') ctitle write(lp,'(a80/a80/a80/a80)') ctitle read( ni,*) iversn,cvarin write(lp,*) cvarin,' = ',iversn if (cvarin.ne.'iversn') then write(lp,*) write(lp,*) 'error in getdat - input ',cvarin, & ' but should be iversn' write(lp,*) call flush(lp) stop endif read( ni,*) iexpt,cvarin write(lp,*) cvarin,' = ',iexpt if (cvarin.ne.'iexpt ') then write(lp,*) write(lp,*) 'error in getdat - input ',cvarin, & ' but should be iexpt ' write(lp,*) call flush(lp) stop endif read( ni,*) yrflag,cvarin write(lp,*) cvarin,' = ',yrflag if (cvarin.ne.'yrflag') then write(lp,*) write(lp,*) 'error in getdat - input ',cvarin, & ' but should be yrflag' write(lp,*) call flush(lp) stop endif read( ni,*) idmtst,cvarin write(lp,*) cvarin,' = ',idmtst if (cvarin.ne.'idm ') then write(lp,*) write(lp,*) 'error in getdat - input ',cvarin, & ' but should be idm ' write(lp,*) call flush(lp) stop endif read( ni,*) jdmtst,cvarin write(lp,*) cvarin,' = ',jdmtst if (cvarin.ne.'jdm ') then write(lp,*) write(lp,*) 'error in getdat - input ',cvarin, & ' but should be jdm ' write(lp,*) call flush(lp) stop endif c if (idmtst.ne.idm .or. jdmtst.ne.jdm) then write(lp,*) write(lp,*) 'error in getdat - input idm,jdm', & ' not consistent with parameters' write(lp,*) 'idm,jdm = ',idm, jdm, ' (REGION.h)' write(lp,*) 'idm,jdm = ',idmtst,jdmtst,' (input)' write(lp,*) call flush(lp) stop endif c c --- artype== 1 for normal archive files c --- artype==-1 for normal archive files with p-vel c --- artype== 2 for mean archive files c --- artype==-2 for mean archive files with p-vel c --- artype== 3 for stddev archive files c --- artype== 4 for diff archive files c read( ni,'(a)') cline write(lp,'(a)') cline(1:len_trim(cline)) if (cline(25:28).eq.'mean') then artype = 2 elseif (cline(25:28).eq.'std.') then artype = 3 elseif (cline(25:28).eq.'diff') then artype = 4 else artype = 1 endif if (cline(1:7).eq.'field_p') then artype = -artype endif write(lp,'(a,i2)') 'artype =',artype c if (artype.ne.1) then write(lp,*) write(lp,*) 'error in getdata1 - artype must be 1' write(lp,*) call flush(lp) stop endif c if (.not.l_arch(1)) then nodens = .true. sigver = 4 !a guess thbase = 34.0 !a guess montg(:,:) = 0.0 else read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) if (cline(1:8).ne.c_arc8( 1)) then write(lp,'("error: input ",a," but expected ",a)') & cline(1:8),c_arc8( 1) call flush(lp) stop endif i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb nodens = layer.ne.0 !detect version 2.2 normal archive files if (nodens) then sigver = layer thbase = thet else sigver = 0 endif call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & montg,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'montg ' * --- discard montg * write(lp,'("input ",a," into ",a)') cline(1:8),'work ' endif !l_arch c if (.not.l_arch(2)) then srfht(:,:) = 0.0 else read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) if (cline(1:8).ne.c_arc8( 2)) then write(lp,'("error: input ",a," but expected ",a)') & cline(1:8),c_arc8( 2) call flush(lp) stop endif i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & srfht,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'srfht ' endif !l_arch c if (.not.l_arch(3)) then steric(:,:) = 0.0 lsteric = .false. else read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) if (cline(1:8).ne.c_arc8( 3)) then write(lp,'("error: input ",a," but expected ",a)') & cline(1:8),c_arc8( 3) call flush(lp) stop endif i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) lsteric = .true. call extrct_p(work,idm,jdm,iorign,jorign, & steric,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'steric ' endif !l_arch c if (.not.l_arch(4)) then surflx(:,:) = 0.0 else read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) if (cline(1:8).ne.c_arc8( 4)) then write(lp,'("error: input ",a," but expected ",a)') & cline(1:8),c_arc8( 4) call flush(lp) stop endif if (cline(1:8).ne.c_arc8( 4)) then write(lp,'("error: input ",a," but expected ",a)') & cline(1:8),c_arc8( 4) call flush(lp) stop endif i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & surflx,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'surflx ' endif !l_arch c if (.not.l_arch(5)) then wtrflx(:,:) = 0.0 else read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) if (cline(1:8).ne.c_arc8( 5)) then write(lp,'("error: input ",a," but expected ",a)') & cline(1:8),c_arc8( 5) call flush(lp) stop endif i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & wtrflx,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'wtrflx ' endif !l_arch c if (.not.l_arch(18)) then salflx(:,:) = 0.0 else read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) if (cline(1:8).ne.c_arc8(18)) then write(lp,'("error: input ",a," but expected ",a)') & cline(1:8),c_arc8( 5) call flush(lp) stop endif i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & salflx,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'salflx ' endif !l_arch c if (.not.l_arch(19)) then surtx(:,:) = 0.0 else read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) if (cline(1:8).ne.c_arc8(19)) then write(lp,'("error: input ",a," but expected ",a)') & cline(1:8),c_arc8(19) call flush(lp) stop endif i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & surtx,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'surtx ' endif !l_arch c if (.not.l_arch(20)) then surty(:,:) = 0.0 else read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) if (cline(1:8).ne.c_arc8(20)) then write(lp,'("error: input ",a," but expected ",a)') & cline(1:8),c_arc8(20) call flush(lp) stop endif i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & surty,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'surty ' endif !l_arch c if (.not.l_arch(6)) then dpbl(:,:) = 0.0 else read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) if (cline(1:8).ne.c_arc8( 6)) then write(lp,'("error: input ",a," but expected ",a)') & cline(1:8),c_arc8( 6) call flush(lp) stop endif i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & dpbl,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'dpbl ' endif !l_arch c if (.not.l_arch(7)) then dpmixl(:,:) = 0.0 else read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) if (cline(1:8).ne.c_arc8( 7)) then write(lp,'("error: input ",a," but expected ",a)') & cline(1:8),c_arc8( 7) call flush(lp) stop endif i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & dpmixl,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'dpmixl ' endif !l_arch c c --- is there ice? icegln = l_arch(8) .or. l_arch(9) .or. l_arch(10) c if (.not.l_arch(8)) then covice(:,:) = 0.0 else read (ni,'(a)',iostat=ios) cline write(lp,'(a)') cline(1:len_trim(cline)) if (cline(1:8).ne.c_arc8( 8)) then write(lp,'("error: input ",a," but expected ",a)') & cline(1:8),c_arc8( 8) call flush(lp) stop endif i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & covice,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'covice ' endif !l_arch c if (.not.l_arch(9)) then thkice(:,:) = 0.0 else read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) if (cline(1:8).ne.c_arc8( 9)) then write(lp,'("error: input ",a," but expected ",a)') & cline(1:8),c_arc8( 9) call flush(lp) stop endif i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & thkice,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'thkice ' endif !l_arch c if (.not.l_arch(10)) then temice(:,:) = 0.0 else read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) if (cline(1:8).ne.c_arc8(10)) then write(lp,'("error: input ",a," but expected ",a)') & cline(1:8),c_arc8(10) call flush(lp) stop endif i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & temice,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'temice ' endif !l_arch c if (.not.l_arch(11)) then ubaro(:,:) = 0.0 else read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) if (cline(1:8).ne.c_arc8(11)) then write(lp,'("error: input ",a," but expected ",a)') & cline(1:8),c_arc8(11) call flush(lp) stop endif i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .true. ,lrange) call extrct_u(work,idm,jdm,iorign,jorign, & ubaro,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'ubaro ' endif !l_arch c if (.not.l_arch(12)) then vbaro(:,:) = 0.0 else read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) if (cline(1:8).ne.c_arc8(12)) then write(lp,'("error: input ",a," but expected ",a)') & cline(1:8),c_arc8(12) call flush(lp) stop endif i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .true. ,lrange) call extrct_v(work,idm,jdm,iorign,jorign, & vbaro,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'vbaro ' endif !l_arch c kkin=1 do 14 k=1,kkin if (.not.l_arch(13)) then u(:,:,k) = 0.0 else read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) if (cline(1:8).ne.c_arc8(13)) then write(lp,'("error: input ",a," but expected ",a)') & cline(1:8),c_arc8(13) call flush(lp) stop endif i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .true. ,lrange) call extrct_u(work,idm,jdm,iorign,jorign, & u(1,1,k),ii,jj) write(lp,'("input ",a," into ",a,i3)') cline(1:8),'u ',k endif !l_arch c if (.not.l_arch(14)) then v(:,:,k) = 0.0 else read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) if (cline(1:8).ne.c_arc8(14)) then write(lp,'("error: input ",a," but expected ",a)') & cline(1:8),c_arc8(14) call flush(lp) stop endif i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .true. ,lrange) call extrct_v(work,idm,jdm,iorign,jorign, & v(1,1,k),ii,jj) write(lp,'("input ",a," into ",a,i3)') cline(1:8),'v ',k endif !l_arch c if (.not.l_arch(15)) then dp(:,:,k) = 0.0 else read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) if (cline(1:8).ne.c_arc8(15)) then write(lp,'("error: input ",a," but expected ",a)') & cline(1:8),c_arc8(15) call flush(lp) stop endif i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .true., lrange) call extrct_p(work,idm,jdm,iorign,jorign, & dp(1,1,k),ii,jj) write(lp,'("input ",a," into ",a,i3)') cline(1:8),'dp ',k endif !l_arch c if (.not.l_arch(16)) then temp(:,:,k) = 0.0 else read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) if (cline(1:8).ne.c_arc8(16)) then write(lp,'("error: input ",a," but expected ",a)') & cline(1:8),c_arc8(16) call flush(lp) stop endif i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & temp(1,1,k),ii,jj) write(lp,'("input ",a," into ",a,i3)') cline(1:8),'temp ',k endif !l_arch c if (.not.l_arch(17)) then saln(:,:,k) = 0.0 else read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) if (cline(1:8).ne.c_arc8(17)) then write(lp,'("error: input ",a," but expected ",a)') & cline(1:8),c_arc8(17) call flush(lp) stop endif i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & saln(1,1,k),ii,jj) write(lp,'("input ",a," into ",a,i3)') cline(1:8),'saln ',k c endif !l_arch if (l_arch(16) .and. l_arch(17)) then call th3d_p(temp(1,1,k),saln(1,1,k), & th3d(1,1,k),ii,jj, sigver,thbase) write(lp,'(" ",a8,"calculate ",a,i3)') " ",'th3d ',k else th3d(:,:,k) = 0.0 endif c if (k.eq.1) then tmix(:,:) = temp(:,:,1) smix(:,:) = saln(:,:,1) thmix(:,:) = th3d(:,:,1) umix(:,:) = u(:,:,1) vmix(:,:) = v(:,:,1) write(lp,'("copy ",a," into ",a)') 'temp.1 ','tmix ' write(lp,'("copy ",a," into ",a)') 'saln.1 ','smix ' write(lp,'("copy ",a," into ",a)') 'th3d.1 ','thmix ' write(lp,'("copy ",a," into ",a)') ' u.1 ','umix ' write(lp,'("copy ",a," into ",a)') ' v.1 ','vmix ' endif !k==1 c write(lp,'(a,f9.5)') 'finished reading data for layer',thet call flush(lp) theta(k)=thet 14 continue c close( unit=ni) call zaiocl(ni) write(lp,'(a)') 'closed archive file' call flush(lp) c time(1) = timedum time(2) = timedum time(3) = timedum call time_hour(time) !reset, assuming time is on the hour write(lp,*) 'time3 = ',time c if (initl) then c --- acquire basin depths and land/sea mask call getdepth(work) end if c * write(lp,'(a)') 'shown below: sea surface height' * call zebra(srfht,ii,ii1,jj1) * call flush(lp) c return c c --- unexpected end of file 6 continue write (lp,*) '***** unexpected end of archive file *****' call flush(lp) stop '(e-o-f)' end subroutine getdatas(flnm,time,artype,lrange,initl,lsteric,icegln, & iexpt,iversn,yrflag,kkin, work) use mod_plot ! HYCOM plot array interface use mod_za ! HYCOM array I/O interface c character flnm*(*) double precision time(3) logical lrange,initl,lsteric,icegln integer artype,iexpt,iversn,yrflag,kkin real work(idm,jdm) c c --- read model fields and extract portion of global fields. c --- HYCOM 2.0 array I/O std archive file. c --- for "3z", so keep mnthknss and discard thknss. c --- (no time-averaged fluxes in this version). c character cline*80 character preambl(5)*79 character cvarin*6 real hminb,hmaxb integer i,j,ios,l,k,ktr,ntr logical lke double precision timedum c data ni/14/ c l = len_trim(flnm) open (unit=ni,file=flnm(1:l-2)//'.b',form='formatted', & status='old',action='read') call zaiopf(flnm(1:l-2)//'.a','old', ni) c read( ni,'(a80/a80/a80/a80)') ctitle write(lp,'(a80/a80/a80/a80)') ctitle read( ni,*) iversn,cvarin write(lp,*) cvarin,' = ',iversn if (cvarin.ne.'iversn') then write(lp,*) write(lp,*) 'error in getdat - input ',cvarin, & ' but should be iversn' write(lp,*) call flush(lp) stop endif read( ni,*) iexpt,cvarin write(lp,*) cvarin,' = ',iexpt if (cvarin.ne.'iexpt ') then write(lp,*) write(lp,*) 'error in getdat - input ',cvarin, & ' but should be iexpt ' write(lp,*) call flush(lp) stop endif read( ni,*) yrflag,cvarin write(lp,*) cvarin,' = ',yrflag if (cvarin.ne.'yrflag') then write(lp,*) write(lp,*) 'error in getdat - input ',cvarin, & ' but should be yrflag' write(lp,*) call flush(lp) stop endif read( ni,*) idmtst,cvarin write(lp,*) cvarin,' = ',idmtst if (cvarin.ne.'idm ') then write(lp,*) write(lp,*) 'error in getdat - input ',cvarin, & ' but should be idm ' write(lp,*) call flush(lp) stop endif read( ni,*) jdmtst,cvarin write(lp,*) cvarin,' = ',jdmtst if (cvarin.ne.'jdm ') then write(lp,*) write(lp,*) 'error in getdat - input ',cvarin, & ' but should be jdm ' write(lp,*) call flush(lp) stop endif c if (idmtst.ne.idm .or. jdmtst.ne.jdm) then write(lp,*) write(lp,*) 'error in getdat - input idm,jdm', & ' not consistent with parameters' write(lp,*) 'idm,jdm = ',idm, jdm, ' (REGION.h)' write(lp,*) 'idm,jdm = ',idmtst,jdmtst,' (input)' write(lp,*) call flush(lp) stop endif c c --- artype== 1 for normal archive files c --- artype==-1 for normal archive files with p-vel c --- artype== 2 for mean archive files c --- artype==-2 for mean archive files with p-vel c --- artype== 3 for stddev archive files c --- artype== 4 for diff archive files c read( ni,'(a)') cline write(lp,'(a)') cline(1:len_trim(cline)) if (cline(25:28).eq.'mean') then artype = 2 elseif (cline(25:28).eq.'std.') then artype = 3 elseif (cline(25:28).eq.'diff') then artype = 4 else artype = 1 endif if (cline(1:7).eq.'field_p') then artype = -artype endif write(lp,'(a,i2)') 'artype =',artype c if (artype.ne.3) then write(lp,*) write(lp,*) 'error in getdatas - only for artype = 3' write(lp,*) call flush(lp) stop endif c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,time(1),layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & montg,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'montg ' * --- discard montg * write(lp,'("input ",a," into ",a)') cline(1:8),'work ' c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,time(2),layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & srfht,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'srfht ' c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,time(3),layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) lsteric = cline(1:8).eq.'steric ' if (lsteric) then call extrct_p(work,idm,jdm,iorign,jorign, & steric,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'steric ' read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) else steric(:,:) = 0.0 endif loneta = cline(1:8).eq.'oneta ' if (loneta) then call extrct_p(work,idm,jdm,iorign,jorign, & oneta,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'oneta ' read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) if (abs(artype).ge.3) then !std or dif if (.not. allocated(onetas)) then allocate( onetas(ii,jj) ) endif onetas(:,:) = oneta(:,:) write(lp,'("copy ",a," into ",a)') 'oneta ','onetas ' call extrct_p(work,idm,jdm,iorign,jorign, & oneta,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'oneta ' read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) endif !std or dif else oneta(:,:) = 1.0 !not used? endif call extrct_p(work,idm,jdm,iorign,jorign, & surflx,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'surflx ' call time_hour(time) !reset, assuming time is on the hour write(lp,*) 'time3 = ',time c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) if (cline(1:8).ne.'wtrflx ') then wtrflx(:,:) = 0.0 else lwtrflx = .true. call extrct_p(work,idm,jdm,iorign,jorign, & wtrflx,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'wtrflx ' read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,time(3),layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) endif call extrct_p(work,idm,jdm,iorign,jorign, & salflx,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'salflx ' c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & dpbl,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'dpbl ' c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & dpmixl,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'dpmixl ' c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & tmix,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'tmix ' c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & smix,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'smix ' c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & thmix,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'thmix ' c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .true. ,lrange) call extrct_u(work,idm,jdm,iorign,jorign, & umix,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'umix ' c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .true. ,lrange) call extrct_v(work,idm,jdm,iorign,jorign, & vmix,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'vmix ' c c --- is there ke? read (ni,'(a)',iostat=ios) cline write(lp,'(a)') cline(1:len_trim(cline)) lke = artype.gt.1 .and. ios.eq.0 .and. cline(1:8).eq.'kemix ' if (lke) then ! mean or std. archive with ke if (.not. allocated(kemix)) then allocate( kemix(ii,jj) ) endif if (.not. allocated(kebaro)) then allocate( kebaro(ii,jj) ) endif if (.not. allocated(ke)) then allocate( ke(ii,jj,kkmax) ) endif i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .true. ,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & kemix,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'kemix ' read (ni,'(a)',iostat=ios) cline write(lp,'(a)') cline(1:len_trim(cline)) endif c c --- is there ice? * read (ni,'(a)',iostat=ios) cline * write(lp,'(a)') cline(1:len_trim(cline)) icegln = ios.eq.0 .and. cline(1:8).eq.'covice ' if (icegln) then i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & covice,ii,jj) c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & thkice,ii,jj) c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & temice,ii,jj) c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) else covice(:,:) = 0.0 thkice(:,:) = 0.0 temice(:,:) = 0.0 endif c i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .true. ,lrange) call extrct_u(work,idm,jdm,iorign,jorign, & ubaro,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'ubaro ' c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .true. ,lrange) call extrct_v(work,idm,jdm,iorign,jorign, & vbaro,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'vbaro ' c if (lke) then ! mean or std. archive with ke read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .true. ,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & kebaro,ii,jj) write(lp,'("input ",a," into ",a)') cline(1:8),'kebaro ' endif c kkin=1 do 14 k=1,kk if (k.eq.2) then c --- already input at end of k=1 loop. else read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) endif i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb if (cline(1:8).ne.'u-vel. ') then write(lp,*) write(lp,*) 'error in getdat - layer ',k, & ' does not exist (kk= ',kk,')' write(lp,*) call flush(lp) stop endif call getfld( work, ni, hminb,hmaxb, .true. ,lrange) call extrct_u(work,idm,jdm,iorign,jorign, & u(1,1,k),ii,jj) write(lp,'("input ",a," into ",a,i3)') cline(1:8),'u ',k c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .true. ,lrange) call extrct_v(work,idm,jdm,iorign,jorign, & v(1,1,k),ii,jj) write(lp,'("input ",a," into ",a,i3)') cline(1:8),'v ',k c if (lke) then ! mean or std. archive with ke read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & ke(1,1,k),ii,jj) write(lp,'("input ",a," into ",a,i3)') cline(1:8),'ke ',k endif c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .true., lrange) call extrct_p(work,idm,jdm,iorign,jorign, & dp(1,1,k),ii,jj) write(lp,'("input ",a," into ",a,i3)') cline(1:8),'dp ',k if (cline(1:8).ne.'mnthknss') then write(lp,*) write(lp,*) 'error in getdat - expected mnthknss' write(lp,*) call flush(lp) stop endif c --- discard std. thickness. read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .true., lrange) write(lp,'("skip ",a)') cline(1:8) c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & temp(1,1,k),ii,jj) write(lp,'("input ",a," into ",a,i3)') cline(1:8),'temp ',k c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & saln(1,1,k),ii,jj) write(lp,'("input ",a," into ",a,i3)') cline(1:8),'saln ',k c read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) call extrct_p(work,idm,jdm,iorign,jorign, & th3d(1,1,k),ii,jj) write(lp,'("input ",a," into ",a,i3)') cline(1:8),'th3d ',k c c c --- tracers and visc/diff, may be more in archive than plotted. c if (k.eq.1) then do ktr= 1,999 read (ni,'(a)',iostat=ios) cline write(lp,'(a)') cline(1:len_trim(cline)) if (ios.ne.0) then write(lp,'(a,f9.5)') 'finished reading data for layer',thet call flush(lp) theta(k)=thet goto 114 ! archive containing only 1 layer elseif (cline(1:8).ne.'tracer ' .and. & cline(1:8).ne.'viscty ' .and. & cline(1:8).ne.'t-diff ' .and. & cline(1:8).ne.'s-diff ' ) then exit !end of tracers and visc/diff else i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) if (ktr.le.ntracr) then call extrct_p(work,idm,jdm,iorign,jorign, & trcr(1,1,k,ktr),ii,jj) write(lp,'("input ",a," into ",a,2i3)') & cline(1:8),'trcr ',k,ktr endif endif enddo !ktr ntr=ktr-1 if (ntracr.gt.ntr) then write(lp,*) write(lp,*) 'error in getdat - fewer tracers than requested' write(lp,*) call flush(lp) stop endif else !k.gt.1 do ktr= 1,ntr read (ni,'(a)',end=6) cline write(lp,'(a)') cline(1:len_trim(cline)) i = index(cline,'=') read (cline(i+1:),*) nstep,timedum,layer,thet,hminb,hmaxb call getfld( work, ni, hminb,hmaxb, .false.,lrange) if (ktr.le.ntracr) then call extrct_p(work,idm,jdm,iorign,jorign, & trcr(1,1,k,ktr),ii,jj) write(lp,'("input ",a," into ",a,2i3)') & cline(1:8),'trcr ',k,ktr endif enddo !ktr endif !tracers+visc/diff c ccc write(lp,'(a,i4)') 'shown below: density in layer',k ccc call zebra(th3d(1,1,k),ii,ii1,jj1) c write(lp,'(a,f9.5)') 'finished reading data for layer',thet call flush(lp) theta(k)=thet 14 continue kkin=kk 114 continue c close( unit=ni) call zaiocl(ni) write(lp,'(a)') 'closed archive file' call flush(lp) c if (initl) then c --- acquire basin depths and land/sea mask call getdepth(work) end if c * write(lp,'(a)') 'shown below: sea surface height' * call zebra(srfht,ii,ii1,jj1) * call flush(lp) c return c c --- unexpected end of file 6 continue write (lp,*) '***** unexpected end of archive file *****' call flush(lp) stop '(e-o-f)' end subroutine getdatt(flnm,time,initl, & iexpt,iversn,yrflag,kkin, work) use mod_plot ! HYCOM plot array interface use mod_za ! HYCOM array I/O interface c character flnm*(*) double precision time logical initl integer artype,iexpt,iversn,yrflag,kkin real work(idm,jdm) c c --- read model fields and extract portion of global fields. c --- HYCOM 2.0 and 2.2 text profile archive file. c character cline*240 character preambl(5)*79 character cvarin*6 real hminb,hmaxb,dum integer i,idum,j,ios,l,k,ktr,ntr logical lke double precision timedum c data ni/14/ c write(6,*) 'flnm = ',flnm open (unit=ni,file=flnm,form='formatted', & status='old',action='read') c c --- header c read( ni,'(a)') cline read( ni,'(a)') cline read(cline(3:),*) iexpt,idmtst,jdmtst, & idum,idum,idum,dum,dum, & yrflag c if (idmtst.ne.idm .or. jdmtst.ne.jdm) then write(lp,*) write(lp,*) 'error in getdat - input idm,jdm', & ' not consistent with parameters' write(lp,*) 'idm,jdm = ',idm, jdm, ' (REGION.h)' write(lp,*) 'idm,jdm = ',idmtst,jdmtst,' (input)' write(lp,*) call flush(lp) stop endif c read( ni,'(a)') cline read( ni,'(a)') cline read(cline(2:),*) time, srfht(1,1),dum,dum, & surflx(1,1),dum, & salflx(1,1),dum,dum,dum,dum,dum,dum, & dpbl(1,1), & dpmixl(1,1),dum,dum,dum,dum,dum,dum,dum, & ubaro(1,1), & vbaro(1,1) montg(:,:) = srfht(1,1) !not correct srfht(:,:) = srfht(1,1) surflx(:,:) = surflx(1,1) salflx(:,:) = salflx(1,1) !not correct? dpbl(:,:) = dpbl(1,1) dpmixl(:,:) = dpmixl(1,1) ubaro(:,:) = ubaro(1,1) vbaro(:,:) = vbaro(1,1) c read( ni,'(a)') cline kkin=1 do 14 k=1,kk read (ni,'(a)',end=6) cline read(cline,*) idum,u(1,1,k),v(1,1,k), & temp(1,1,k),saln(1,1,k),th3d(1,1,k), & dp(1,1,k) u(:,:,k) = u(1,1,k) - ubaro(1,1) v(:,:,k) = v(1,1,k) - vbaro(1,1) temp(:,:,k) = temp(1,1,k) saln(:,:,k) = saln(1,1,k) th3d(:,:,k) = th3d(1,1,k) dp(:,:,k) = dp(1,1,k)*9806.0 c if (k.eq.1) then tmix(:,:) = temp(:,:,1) smix(:,:) = saln(:,:,1) thmix(:,:) = th3d(:,:,1) umix(:,:) = u(:,:,1) vmix(:,:) = v(:,:,1) endif !k==1 write(lp,'(a,i3)') 'finished reading data for layer',k call flush(lp) 14 continue kkin=kk 114 continue c c --- thbase? c if (th3d(1,1,kk).lt.33.0) then thbase = 25.0 else thbase = 34.0 endif thmix(:,:) = thmix(:,:) - thbase th3d(:,:,:) = th3d(:,:,:) - thbase close( unit=ni) write(lp,'(a)') 'closed archive file' call flush(lp) c if (initl) then c --- acquire basin depths and land/sea mask call getdepth(work) end if c return c c --- unexpected end of file 6 continue write (lp,*) '***** unexpected end of archive file *****' call flush(lp) stop '(e-o-f)' end subroutine getfld(work, iunit, hminb,hmaxb, lzero,lrange) use mod_za ! HYCOM array I/O interface c c --- read a single array c logical lzero,lrange integer iunit real work(idm,jdm), hminb,hmaxb c integer mask(1) !dummy which is never accessed real hmina,hmaxa c call zaiord(work,mask,.false., hmina,hmaxa, iunit) c if (lrange) then if (abs(hmina-hminb).gt.max(abs(hmina), & abs(hminb))*1.e-4 .or. & abs(hmaxa-hmaxb).gt.max(abs(hmaxa), & abs(hmaxb))*1.e-4 ) then write(lp,'(/ a / a,1p3e14.6 / a,1p3e14.6 /)') & 'error - .a and .b files not consistent:', & '.a,.b min = ',hmina,hminb,hmina-hminb, & '.a,.b max = ',hmaxa,hmaxb,hmaxa-hmaxb call flush(lp) stop endif endif c if (lzero) then do j= 1,jdm do i= 1,idm if (work(i,j).gt.2.0**99) then work(i,j) = 0.0 endif enddo enddo endif return end subroutine time_hour(time) implicit none c double precision time(3) c c --- reset time to an exact hour if very close to an hour. c integer k double precision day,hour,ihr c do k= 1,3 day = int(time(k)) hour = (time(k)-day)*24.d0 ihr = nint(hour) if (abs(hour-ihr).le.0.15d0) then time(k) = day + ihr/24.d0 endif enddo return end subroutine th3d_p(temp,saln,th3d,no,mo,sigver,thbase) implicit none c integer no,mo,sigver real temp(no,mo),saln(no,mo),th3d(no,mo),thbase c c --- calculate density using the appropriate equation of state. c if (sigver.eq.1) then call th3d_p1(temp,saln,th3d,no,mo,thbase) elseif (sigver.eq.2) then call th3d_p2(temp,saln,th3d,no,mo,thbase) elseif (sigver.eq.3) then call th3d_p3(temp,saln,th3d,no,mo,thbase) elseif (sigver.eq.4) then call th3d_p4(temp,saln,th3d,no,mo,thbase) elseif (sigver.eq.5) then call th3d_p5(temp,saln,th3d,no,mo,thbase) elseif (sigver.eq.6) then call th3d_p6(temp,saln,th3d,no,mo,thbase) elseif (sigver.eq.7) then call th3d_p7(temp,saln,th3d,no,mo,thbase) elseif (sigver.eq.8) then call th3d_p8(temp,saln,th3d,no,mo,thbase) elseif (sigver.eq.46) then call th3d_p46(temp,saln,th3d,no,mo,thbase) elseif (sigver.eq.48) then call th3d_p48(temp,saln,th3d,no,mo,thbase) else !unknown th3d(:,:) = 0.0 endif return end subroutine th3d_p1(temp,saln,th3d,no,mo,thbase) implicit none c integer no,mo real temp(no,mo),saln(no,mo),th3d(no,mo),thbase c c --- calculate density using the equation of state. c c spval = data void marker, 2^100 or about 1.2676506e30 real, parameter :: spval=2.0**100 c integer i,j c c include '../../include/stmt_fns_SIGMA0_7term.h' include './stmt_fns_SIGMA0_7term.h' c do j= 1,mo do i= 1,no if (temp(i,j).ne.spval) then th3d(i,j) = sig(r8(temp(i,j)),r8(saln(i,j))) - thbase else th3d(i,j) = spval endif enddo !i enddo !j return end subroutine th3d_p2(temp,saln,th3d,no,mo,thbase) implicit none c integer no,mo real temp(no,mo),saln(no,mo),th3d(no,mo),thbase c c --- calculate density using the equation of state. c c spval = data void marker, 2^100 or about 1.2676506e30 real, parameter :: spval=2.0**100 c integer i,j c c include '../../include/stmt_fns_SIGMA2_7term.h' include './stmt_fns_SIGMA2_7term.h' c do j= 1,mo do i= 1,no if (temp(i,j).ne.spval) then th3d(i,j) = sig(r8(temp(i,j)),r8(saln(i,j))) - thbase else th3d(i,j) = spval endif enddo !i enddo !j return end subroutine th3d_p3(temp,saln,th3d,no,mo,thbase) implicit none c integer no,mo real temp(no,mo),saln(no,mo),th3d(no,mo),thbase c c --- calculate density using the equation of state. c c spval = data void marker, 2^100 or about 1.2676506e30 real, parameter :: spval=2.0**100 c integer i,j c c include '../../include/stmt_fns_SIGMA0_9term.h' include './stmt_fns_SIGMA0_9term.h' c do j= 1,mo do i= 1,no if (temp(i,j).ne.spval) then th3d(i,j) = sig(r8(temp(i,j)),r8(saln(i,j))) - thbase else th3d(i,j) = spval endif enddo !i enddo !j return end subroutine th3d_p4(temp,saln,th3d,no,mo,thbase) implicit none c integer no,mo real temp(no,mo),saln(no,mo),th3d(no,mo),thbase c c --- calculate density using the equation of state. c c spval = data void marker, 2^100 or about 1.2676506e30 real, parameter :: spval=2.0**100 c integer i,j c c include '../../include/stmt_fns_SIGMA2_9term.h' include './stmt_fns_SIGMA2_9term.h' c do j= 1,mo do i= 1,no if (temp(i,j).ne.spval) then th3d(i,j) = sig(r8(temp(i,j)),r8(saln(i,j))) - thbase else th3d(i,j) = spval endif enddo !i enddo !j return end subroutine th3d_p5(temp,saln,th3d,no,mo,thbase) implicit none c integer no,mo real temp(no,mo),saln(no,mo),th3d(no,mo),thbase c c --- calculate density using the equation of state. c c spval = data void marker, 2^100 or about 1.2676506e30 real, parameter :: spval=2.0**100 c integer i,j c c include '../../include/stmt_fns_SIGMA0_17term.h' include './stmt_fns_SIGMA0_17term.h' c do j= 1,mo do i= 1,no if (temp(i,j).ne.spval) then th3d(i,j) = sig(r8(temp(i,j)),r8(saln(i,j))) - thbase else th3d(i,j) = spval endif enddo !i enddo !j return end subroutine th3d_p6(temp,saln,th3d,no,mo,thbase) implicit none c integer no,mo real temp(no,mo),saln(no,mo),th3d(no,mo),thbase c c --- calculate density using the equation of state. c c spval = data void marker, 2^100 or about 1.2676506e30 real, parameter :: spval=2.0**100 c integer i,j c c include '../../include/stmt_fns_SIGMA2_17term.h' include './stmt_fns_SIGMA2_17term.h' c do j= 1,mo do i= 1,no if (temp(i,j).ne.spval) then th3d(i,j) = sig(r8(temp(i,j)),r8(saln(i,j))) - thbase else th3d(i,j) = spval endif enddo !i enddo !j return end subroutine th3d_p7(temp,saln,th3d,no,mo,thbase) implicit none c integer no,mo real temp(no,mo),saln(no,mo),th3d(no,mo),thbase c c --- calculate density using the equation of state. c c spval = data void marker, 2^100 or about 1.2676506e30 real, parameter :: spval=2.0**100 c integer i,j c c include '../../include/stmt_fns_SIGMA0_12term.h' include './stmt_fns_SIGMA0_12term.h' c do j= 1,mo do i= 1,no if (temp(i,j).ne.spval) then th3d(i,j) = sig(r8(temp(i,j)),r8(saln(i,j))) - thbase else th3d(i,j) = spval endif enddo !i enddo !j return end subroutine th3d_p8(temp,saln,th3d,no,mo,thbase) implicit none c integer no,mo real temp(no,mo),saln(no,mo),th3d(no,mo),thbase c c --- calculate density using the equation of state. c c spval = data void marker, 2^100 or about 1.2676506e30 real, parameter :: spval=2.0**100 c integer i,j c c include '../../include/stmt_fns_SIGMA2_12term.h' include './stmt_fns_SIGMA2_12term.h' c do j= 1,mo do i= 1,no if (temp(i,j).ne.spval) then th3d(i,j) = sig(r8(temp(i,j)),r8(saln(i,j))) - thbase else th3d(i,j) = spval endif enddo !i enddo !j return end subroutine th3d_p46(temp,saln,th3d,no,mo,thbase) implicit none c integer no,mo real temp(no,mo),saln(no,mo),th3d(no,mo),thbase c c --- calculate density using the equation of state. c c spval = data void marker, 2^100 or about 1.2676506e30 real, parameter :: spval=2.0**100 c integer i,j c c include '../../include/stmt_fns_SIGMA4_17term.h' include './stmt_fns_SIGMA4_17term.h' c do j= 1,mo do i= 1,no if (temp(i,j).ne.spval) then th3d(i,j) = sig(r8(temp(i,j)),r8(saln(i,j))) - thbase else th3d(i,j) = spval endif enddo !i enddo !j return end subroutine th3d_p48(temp,saln,th3d,no,mo,thbase) implicit none c integer no,mo real temp(no,mo),saln(no,mo),th3d(no,mo),thbase c c --- calculate density using the equation of state. c c spval = data void marker, 2^100 or about 1.2676506e30 real, parameter :: spval=2.0**100 c integer i,j c c include '../../include/stmt_fns_SIGMA4_12term.h' include './stmt_fns_SIGMA4_12term.h' c do j= 1,mo do i= 1,no if (temp(i,j).ne.spval) then th3d(i,j) = sig(r8(temp(i,j)),r8(saln(i,j))) - thbase else th3d(i,j) = spval endif enddo !i enddo !j return end