subroutine xtract(map_time,map_opt,map_tx,infname) c c======================================================================= c === c This routine extracts initial and boundary data for the domain === c specified in NetCDF file INFNAME. === c === c Calls: NCOPN, NCPOPT, NCVGT, NCVGT1, NCCLOS, NCVID, NCVPT === c (NetCDF library) === c EXITUS, LNBLK, XTR_PSI, XTR_TRC, XTR_VEL, XTR_VOR === c === c======================================================================= c c----------------------------------------------------------------------- c Define global data. c----------------------------------------------------------------------- c #include #include #include #include #include c c----------------------------------------------------------------------- c Define local data. c----------------------------------------------------------------------- c integer ib,imax,j,jmax,kmax,lenstr,m,map_crd,map_opt,map_tx, * m_pbryid,m_piniid,m_qbryid,m_tbryid,m_tinpid,m_vbryid, * m_viniid,ncid,ntrc,pbgridid,qbgridid,tbgridid,vbgridid integer lnblk integer count(5),map_imx(4),m_tiniid(nt),start(5) FLOAT * map_rlatd,map_rlngd,map_time,map_thetad FLOAT * map_dep(ximtkm),map_lon(ximt),map_lat(ximt),map_p(ximt), * map_pt(ximt),map_s(ximtkm,nt),map_v(ximtkm,2) character*44 fldnam character*(*) infname c c======================================================================= c Begin executable code. c======================================================================= c c Open sub-domain NetCDF file for read/write. c call ncpopt(ncverbos) lenstr=lnblk(infname,len(infname)) ncid=ncopn(infname(1:lenstr),ncwrite,rcode) if(rcode.ne.0) then write(stdout,900) infname(1:lenstr) call exitus('XTRACT') endif c c Read in and check main dimension parameters. c varid=ncvid(ncid,'imt',rcode) if(rcode.eq.0) then call ncvgt1(ncid,varid,1,imax,rcode) else write(stdout,901) 'imt' call exitus('XTRACT') endif varid=ncvid(ncid,'jmt',rcode) if(rcode.eq.0) then call ncvgt1(ncid,varid,1,jmax,rcode) else write(stdout,901) 'jmt' call exitus('XTRACT') endif if(max(imax,jmax).gt.ximt) then write(stdout,902) 'XIMT = ',max(imax,jmax) call exitus('XTRACT') endif c varid=ncvid(ncid,'km',rcode) if(rcode.eq.0) then call ncvgt1(ncid,varid,1,kmax,rcode) else write(stdout,901) 'km' call exitus('XTRACT') endif if(max(imax,jmax)*kmax.gt.ximtkm) then write(stdout,902) 'XIMTKM = ',max(imax,jmax)*kmax call exitus('XTRACT') endif c varid=ncvid(ncid,'nt',rcode) if(rcode.eq.0) then call ncvgt1(ncid,varid,1,ntrc,rcode) if(ntrc.ne.nt) then write(stdout,903) 'NT, NTRC: ',nt,ntrc call exitus('XTRACT') endif else write(stdout,901) 'nt' call exitus('XTRACT') endif c c Read in sub-domain grid definition. c varid=ncvid(ncid,'coord',rcode) if(rcode.eq.0) then call ncvgt1(ncid,varid,1,map_crd,rcode) else write(stdout,901) 'coord' call exitus('XTRACT') endif varid=ncvid(ncid,'rlngd',rcode) if(rcode.eq.0) then call ncvgt1(ncid,varid,1,map_rlngd,rcode) else write(stdout,901) 'rlngd' call exitus('XTRACT') endif varid=ncvid(ncid,'rlatd',rcode) if(rcode.eq.0) then call ncvgt1(ncid,varid,1,map_rlatd,rcode) else write(stdout,901) 'rlatd' call exitus('XTRACT') endif varid=ncvid(ncid,'thetad',rcode) if(rcode.eq.0) then call ncvgt1(ncid,varid,1,map_thetad,rcode) else write(stdout,901) 'thetad' call exitus('XTRACT') endif c c Get unlimitted time dimension ID. c m_tinpid=ncvid(ncid,'time',rcode) if(rcode.ne.0) then write(stdout,901) 'time' call exitus('XTRACT') endif c c c======================================================================= c Process initial conditions data. ==================================== c======================================================================= c if(map_opt.eq.0) then c c======================================================================= c Extract, interpolate and write out initial conditions data. c======================================================================= c c----------------------------------------------------------------------- c Internal mode velocity initial conditions. c----------------------------------------------------------------------- c c Inquire NetCDF ID for variable and its grid. c m_viniid=ncvid(ncid,'vclin',rcode) if(rcode.ne.0) then write(stdout,901) 'vclin' call exitus('XTRACT') endif varid=ncvid(ncid,'vgrid3',rcode) if(rcode.ne.0) then write(stdout,901) 'vgrid3' call exitus('XTRACT') endif c c Extract and interpolate internal velocity to sub-domain grid c row-by-row. c do 10 j=1,jmax c c Get grid information. c start(1)=xindx count(1)=1 start(2)=1 count(2)=1 start(3)=1 count(3)=imax start(4)=j count(4)=1 call ncvgt(ncid,varid,start,count,map_lon,rcode) if(rcode.ne.0) then write(stdout,904) 'vgrid3 x-axis',j call exitus('XTRACT') endif start(1)=yindx count(1)=1 call ncvgt(ncid,varid,start,count,map_lat,rcode) if(rcode.ne.0) then write(stdout,904) 'vgrid3 y-axis',j call exitus('XTRACT') endif start(1)=zindx count(1)=1 start(2)=1 count(2)=kmax call ncvgt(ncid,varid,start,count,map_dep,rcode) if(rcode.ne.0) then write(stdout,904) 'vgrid3 z-axis',j call exitus('XTRACT') endif c c Extract and interpolate internal mode velocities. c call xtr_vel(map_lon,map_lat,map_dep,map_v,imax,kmax, * map_crd,map_rlngd,map_rlatd,map_thetad) c c Write interpolated internal mode velocity into NetCDF file. c start(1)=xindx count(1)=1 start(2)=1 count(2)=kmax start(3)=1 count(3)=imax start(4)=j count(4)=1 start(5)=1 count(5)=1 call ncvpt(ncid,m_viniid,start,count,map_v(1,1),rcode) if(rcode.ne.0) then write(stdout,905) 'vclin x-component',j call exitus('XTRACT') endif start(1)=yindx call ncvpt(ncid,m_viniid,start,count,map_v(1,2),rcode) if(rcode.ne.0) then write(stdout,905) 'vclin y-component',j call exitus('XTRACT') endif 10 continue c c----------------------------------------------------------------------- c Tracers initial conditions c----------------------------------------------------------------------- c c Inquire NetCDF ID for variable and its grid. c do 20 m=1,nt fldnam=tname(1,m) lenstr=lnblk(fldnam,len(fldnam)) m_tiniid(m)=ncvid(ncid,fldnam(1:lenstr),rcode) if(rcode.ne.0) then write(stdout,901) fldnam(1:lenstr) call exitus('XTRACT') endif 20 continue varid=ncvid(ncid,'tgrid3',rcode) if(rcode.ne.0) then write(stdout,901) 'tgrid3' call exitus('XTRACT') endif c c Extract and interpolate tracers to sub-domain grid row-by-row. c do 40 j=1,jmax c c Get grid information. c start(1)=xindx count(1)=1 start(2)=1 count(2)=1 start(3)=1 count(3)=imax start(4)=j count(4)=1 call ncvgt(ncid,varid,start,count,map_lon,rcode) if(rcode.ne.0) then write(stdout,904) 'tgrid3 x-axis',j call exitus('XTRACT') endif start(1)=yindx count(1)=1 call ncvgt(ncid,varid,start,count,map_lat,rcode) if(rcode.ne.0) then write(stdout,904) 'tgrid3 y-axis',j call exitus('XTRACT') endif start(1)=zindx count(1)=1 start(2)=1 count(2)=kmax call ncvgt(ncid,varid,start,count,map_dep,rcode) if(rcode.ne.0) then write(stdout,904) 'tgrid3 z-axis',j call exitus('XTRACT') endif c c Extract and interpolate tracers. c call xtr_trc(map_lon,map_lat,map_dep,map_s,imax,kmax) c c Write interpolated tracers into NetCDF file. c start(1)=1 count(1)=kmax start(2)=1 count(2)=imax start(3)=j count(3)=1 start(4)=1 count(4)=1 do 30 m=1,nt call ncvpt(ncid,m_tiniid(m),start,count,map_s(1,m),rcode) if(rcode.ne.0) then write(stdout,906) 'tini',j,m call exitus('XTRACT') endif 30 continue 40 continue c c----------------------------------------------------------------------- c Transport streamfunction initial conditions. c----------------------------------------------------------------------- c c Inquire NetCDF ID for variable and its grid. c m_piniid=ncvid(ncid,'pbar',rcode) if(rcode.ne.0) then write(stdout,901) 'pbar' call exitus('XTRACT') endif varid=ncvid(ncid,'tgrid2',rcode) if(rcode.ne.0) then write(stdout,901) 'tgrid2' call exitus('XTRACT') endif c c Interpolate transport streamfunction to sub-domain grid row-by-row. c do 50 j=1,jmax c c Get grid information. c start(1)=xindx count(1)=1 start(2)=1 count(2)=imax start(3)=j count(3)=1 call ncvgt(ncid,varid,start,count,map_lon,rcode) if(rcode.ne.0) then write(stdout,904) 'tgrid2 x-axis',j call exitus('XTRACT') endif start(1)=yindx count(1)=1 call ncvgt(ncid,varid,start,count,map_lat,rcode) if(rcode.ne.0) then write(stdout,904) 'tgrid2 y-axis',j call exitus('XTRACT') endif c c Extract and interpolate transport streamfunction. c call xtr_psi(map_lon,map_lat,map_p,imax) c c Write interpolated transport streamfunction into NetCDF file. c start(1)=1 count(1)=imax start(2)=j count(2)=1 start(3)=1 count(3)=1 call ncvpt(ncid,m_piniid,start,count,map_p,rcode) if(rcode.ne.0) then write(stdout,906) 'pbar',j call exitus('XTRACT') endif 50 continue endif c c======================================================================= c Process boundary conditions data. =================================== c======================================================================= c if((map_opt.eq.0).or.(map_opt.eq.1)) then c c Inquire NetCDF ID for boundary conditions variables and their grid. c m_pbryid=ncvid(ncid,'pbry',rcode) if(rcode.ne.0) then write(stdout,901) 'pbry' call exitus('XTRACT') endif m_qbryid=ncvid(ncid,'qbry',rcode) if(rcode.ne.0) then write(stdout,901) 'qbry' call exitus('XTRACT') endif m_vbryid=ncvid(ncid,'vbry',rcode) if(rcode.ne.0) then write(stdout,901) 'vbry' call exitus('XTRACT') endif m_tbryid=ncvid(ncid,'tbry',rcode) if(rcode.ne.0) then write(stdout,901) 'tbry' call exitus('XTRACT') endif vbgridid=ncvid(ncid,'vbgrid3',rcode) if(rcode.ne.0) then write(stdout,901) 'vbgrid3' call exitus('XTRACT') endif tbgridid=ncvid(ncid,'tbgrid3',rcode) if(rcode.ne.0) then write(stdout,901) 'tbgrid3' call exitus('XTRACT') endif pbgridid=ncvid(ncid,'tbgrid2',rcode) if(rcode.ne.0) then write(stdout,901) 'tbgrid2' call exitus('XTRACT') endif qbgridid=ncvid(ncid,'qbgrid2',rcode) if(rcode.ne.0) then write(stdout,901) 'qbgrid2' call exitus('XTRACT') endif c c======================================================================= c Extract, interpolate and write out boundary conditions data. c======================================================================= c map_imx(1)=jmax map_imx(2)=imax map_imx(3)=jmax map_imx(4)=imax c do 70 ib=1,4 c c----------------------------------------------------------------------- c Internal mode velocity boundary conditions. c----------------------------------------------------------------------- c c Get grid information. c start(1)=xindx count(1)=1 start(2)=1 count(2)=1 start(3)=1 count(3)=map_imx(ib) start(4)=ib count(4)=1 call ncvgt(ncid,vbgridid,start,count,map_lon,rcode) if(rcode.ne.0) then write(stdout,907) 'vbgrid3 x-axis',ib call exitus('XTRACT') endif start(1)=yindx count(1)=1 call ncvgt(ncid,vbgridid,start,count,map_lat,rcode) if(rcode.ne.0) then write(stdout,907) 'vbgrid3 y-axis',ib call exitus('XTRACT') endif start(1)=zindx count(1)=1 start(2)=1 count(2)=kmax call ncvgt(ncid,vbgridid,start,count,map_dep,rcode) if(rcode.ne.0) then write(stdout,907) 'vbgrid3 z-axis',ib call exitus('XTRACT') endif c c Extract and interpolate internal mode velocities at the boundary. c call xtr_vel(map_lon,map_lat,map_dep,map_v,map_imx(ib),kmax, * map_crd,map_rlngd,map_rlatd,map_thetad) c c Write out interpolated boundary internal mode velocities into NetCDF. c start(1)=xindx count(1)=1 start(2)=1 count(2)=kmax start(3)=1 count(3)=map_imx(ib) start(4)=ib count(4)=1 start(5)=map_tx count(5)=1 call ncvpt(ncid,m_vbryid,start,count,map_v(1,1),rcode) if(rcode.ne.0) then write(stdout,908) 'vbry x-component',ib call exitus('XTRACT') endif start(1)=yindx count(1)=1 call ncvpt(ncid,m_vbryid,start,count,map_v(1,2),rcode) if(rcode.ne.0) then write(stdout,908) 'vbry y-component',ib call exitus('XTRACT') endif c c----------------------------------------------------------------------- c Tracers boundary conditions. c----------------------------------------------------------------------- c c Get grid information. c start(1)=xindx count(1)=1 start(2)=1 count(2)=1 start(3)=1 count(3)=map_imx(ib) start(4)=ib count(4)=1 call ncvgt(ncid,tbgridid,start,count,map_lon,rcode) if(rcode.ne.0) then write(stdout,907) 'tbgrid3 x-axis',ib call exitus('XTRACT') endif start(1)=yindx count(1)=1 call ncvgt(ncid,tbgridid,start,count,map_lat,rcode) if(rcode.ne.0) then write(stdout,907) 'tbgrid3 y-axis',ib call exitus('XTRACT') endif start(1)=zindx count(1)=1 start(2)=1 count(2)=kmax call ncvgt(ncid,tbgridid,start,count,map_dep,rcode) if(rcode.ne.0) then write(stdout,907) 'tbgrid3 z-axis',ib call exitus('XTRACT') endif c c Extract and interpolate tracers at boundary. c call xtr_trc(map_lon,map_lat,map_dep,map_s,map_imx(ib),kmax) c c Write out interpolated boundary tracers into NetCDF file. c do 60 m=1,nt start(1)=m count(1)=1 start(2)=1 count(2)=kmax start(3)=1 count(3)=map_imx(ib) start(4)=ib count(4)=1 start(5)=map_tx count(5)=1 call ncvpt(ncid,m_tbryid,start,count,map_s(1,m),rcode) if(rcode.ne.0) then write(stdout,909) 'tbry',ib,m call exitus('XTRACT') endif 60 continue c c----------------------------------------------------------------------- c Transport streamfunction boundary conditions. c----------------------------------------------------------------------- c c Get grid information. c start(1)=xindx count(1)=1 start(2)=1 count(2)=map_imx(ib) start(3)=ib count(3)=1 call ncvgt(ncid,pbgridid,start,count,map_lon,rcode) if(rcode.ne.0) then write(stdout,907) 'tbgrid2 x-axis',ib call exitus('XTRACT') endif start(1)=yindx count(1)=1 call ncvgt(ncid,pbgridid,start,count,map_lat,rcode) if(rcode.ne.0) then write(stdout,907) 'tbgrid2 y-axis',ib call exitus('XTRACT') endif c c Extract and interpolate transport. c call xtr_psi(map_lon,map_lat,map_p,map_imx(ib)) c c Write out boundary transport and vorticity into NetCDF file. c start(1)=1 count(1)=map_imx(ib) start(2)=ib count(2)=1 start(3)=map_tx count(3)=1 call ncvpt(ncid,m_pbryid,start,count,map_p,rcode) if(rcode.ne.0) then write(stdout,908) 'pbry',ib call exitus('XTRACT') endif c c----------------------------------------------------------------------- c Time rate of change of vorticity boundary conditions. c----------------------------------------------------------------------- c c Get grid information. c start(1)=xindx count(1)=1 start(2)=1 count(2)=map_imx(ib) start(3)=ib count(3)=1 call ncvgt(ncid,qbgridid,start,count,map_lon,rcode) if(rcode.ne.0) then write(stdout,907) 'qbgrid2 x-axis',ib call exitus('XTRACT') endif start(1)=yindx count(1)=1 call ncvgt(ncid,qbgridid,start,count,map_lat,rcode) if(rcode.ne.0) then write(stdout,907) 'qbgrid2 y-axis',ib call exitus('XTRACT') endif c c Extract and interpolate transport. c call xtr_vor(map_lon,map_lat,map_pt,map_imx(ib)) c c Write out time rate of change of vorticity into NetCDF file. c start(1)=1 count(1)=map_imx(ib) start(2)=ib count(2)=1 start(3)=map_tx count(3)=1 call ncvpt(ncid,m_qbryid,start,count,map_pt,rcode) if(rcode.ne.0) then write(stdout,908) 'qbry',ib call exitus('XTRACT') endif 70 continue c c----------------------------------------------------------------------- c Deactivate switch for persistent boundary conditions. c----------------------------------------------------------------------- c if(map_tx.eq.2) then varid=ncvid(ncid,'iflag',rcode) if(rcode.ne.0) then write(stdout,901) 'iflag' call exitus('XTRACT') endif start(1)=3 count(1)=1 call ncvpt(ncid,varid,start,count,0,rcode) if(rcode.ne.0) then write(stdout,910) 'iflag',3 call exitus('XTRACT') endif endif c c======================================================================= c Write out time coordinate. c======================================================================= c start(1)=map_tx count(1)=1 call ncvpt(ncid,m_tinpid,start,count,map_time,rcode) if(rcode.ne.0) then write(stdout,910) 'time',m_tinpid call exitus('XTRACT') endif endif c c======================================================================= c Close sub-domain NetCDF file. ====================================== c======================================================================= c call ncclos(ncid,rcode) c 900 format(/,' XTRACT - unable to open sub-domain NetCDF file: ',a) 901 format(/,' XTRACT - cannot find variable: ',a,2x, * ' in sub-domain NetCDF file.') 902 format(/,' XTRACT - underdimensioned parameter: ',a,i4, * ' reset include file param.h and recompile.') 903 format(/,' XTRACT - inconsistent dimension parameters, ',a,2i4) 904 format(/,' XTRACT - error while reading variable: ',a,2x, * ' at row J = ',i5) 905 format(/,' XTRACT - error while writing variable: ',a,2x, * ' at row J = ',i5) 906 format(/,' XTRACT - error while writing variable: ',a,2x, * ' at row J = ',i5,2x,' and TRACER = ',i2) 907 format(/,' XTRACT - error while reading variable: ',a,2x, * ' at BOUNDARY = ',i2) 908 format(/,' XTRACT - error while writing variable: ',a,2x, * ' at boundary = ',i1) 909 format(/,' XTRACT - error while writing variable: ',a,2x, * ' at boundary = ',i1,' and TRACER = ',i2) 910 format(/,' XTRACT - error while writing variable: ',a,2x, * ' at index = ',i4) return end