module io use const use var use comm implicit real*8 (a-h,o-z) # include "pnetcdf.inc" integer(kind=mpi_offset_kind) nn,ns_kji,nc_kji,ns_tji,nc_tji,ns_ji,nc_ji,ns_1,nc_1,nf_kji common/pnetcdf/nn(6),ns_kji(3),nc_kji(3),ns_tji(3),nc_tji(3),ns_ji(2),nc_ji(2),ns_1,nc_1,nf_kji(3) integer(kind=mpi_offset_kind) ns_kji2,nc_kji2,ns_tji2,nc_tji2,ns_ji2,nc_ji2,nf_kji2 common/pnetcdf2/ns_kji2(3),nc_kji2(3),ns_tji2(3),nc_tji2(3),ns_ji2(2),nc_ji2(2),nf_kji2(3) contains subroutine init_io open(14,file='data/glo'//grd,form='formatted') end subroutine ! ---------------------------------------------------------------------- subroutine write_hist parameter(i01=i0+1,j01=j0+1,nbg0=nb0*ngy0,nbg1=nbg0-1,ibir=i2t/ngy0) character fn*24 integer*2 nbf real*8 rhoavg real*8 lwupavg,lwdnavg,lathavg,kpp_src_t,kpp_src_s,ioffavg, & meltavg,meltHavg,ioffFavg common/histavg/pavg(i0,j0,k1),uavg(i0,j0,k1), & vavg(i0,j0,k1),tavg(i0,j0,k1),cavg(i0,j0,k1), & savg(i0,j0,k1),wcavg(i0,j0,k0), & evavg(i0,j0,k0),hvavg(i0,j0,k0), & dmxavg(i0,j0,k1),dmyavg(i0,j0,k1),rhoavg(i0,j0,k1),& tauxavg(i2,j2,1),tauyavg(i2,j2,1),lathavg(i2,j2,1),& senhavg(i2,j2,1),qdot2avg(i2,j2,1),qdotavg(i2,j2,1),& evapoavg(i2,j2,1),precavg(i2,j2,1),& kpp_src_t(i0,j0,k1),kpp_src_s(i0,j0,k1), & rainavg(i2,j2,1),roffavg(i2,j1,1),ioffavg(i2,j2,1),& meltavg(i2,j2,1),snowavg(i2,j2,1),lwupavg(i2,j2,1),& lwdnavg(i2,j2,1),meltHavg(i2,j2,1),snowFavg(i2,j2,1),& ioffFavg(i2,j2,1),saltavg(i2,j2,1),qflxavg(i2,j2,1),& hbltavg(i2,j2,1) dimension nbf(i2*j2*k1),nda(3),ndb(2),ndc(3),rbf(i2*j2*k1),rbfw(i2*j2*k0),rmbf(i2*j2*12) real*8 drbf(i2*j2*k1) ! for attributes character(50)name,long_name,units,coords integer(kind=mpi_offset_kind) length call timeavg(p,pavg,k1,wopt) call timeavg(u2,uavg,k1,wopt) call timeavg(v2,vavg,k1,wopt) call timeavg(t2,tavg,k1,wopt) call timeavg(s2,savg,k1,wopt) call timeavg(dmx,dmxavg,k1,wopt) call timeavg(dmy,dmyavg,k1,wopt) call timeavg(rho,rhoavg,k1,wopt) !yc call timeavg(c2,cavg,k1,wopt) !yc call timeavg(kpp_src(:,:,:,1),kpp_src_t,k1,wopt) call timeavg(kpp_src(:,:,:,2),kpp_src_s,k1,wopt) call timeavg_2d(kpp_hblt(2:i1,2:j1),hbltavg,wopt) call timeavg_2d(taux,tauxavg,wopt) call timeavg_2d(tauy,tauyavg,wopt) call timeavg_2d(lath,lathavg,wopt) call timeavg_2d(senh,senhavg,wopt) call timeavg_2d(qdot2,qdot2avg,wopt) call timeavg_2d(qdot,qdotavg,wopt) call timeavg_2d(evapo,evapoavg,wopt) call timeavg_2d(prec,precavg,wopt) call timeavg_2d(rain,rainavg,wopt) call timeavg_2d(roff,roffavg,wopt) call timeavg_2d(ioff,ioffavg,wopt) call timeavg_2d(melt,meltavg,wopt) call timeavg_2d(snow,snowavg,wopt) call timeavg_2d(lwup,lwupavg,wopt) call timeavg_2d(lwdn,lwdnavg,wopt) call timeavg_2d(meltH,meltHavg,wopt) call timeavg_2d(snow_F,snowFavg,wopt) call timeavg_2d(ioff_F,ioffFavg,wopt) call timeavg_2d(salt,saltavg,wopt) do 100 k=1,k0 do 100 j=2,j1 do 100 i=2,i1 100 wcavg(i,j,k)=wcavg(i,j,k)+wopt*w(i,j,k) do 101 k=2,k1 do 101 j=2,j1 do 101 i=2,i1 evavg(i,j,k)=evavg(i,j,k)+wopt*ev(i-1,j-1,k-1) 101 hvavg(i,j,k)=hvavg(i,j,k)+wopt*hv(i-1,j-1,k-1) ! derive timeavg field only. if (mod(itf,nopt*itfday) .ne. 0) return if(myid.eq.0) print*,'write output' mon = n360/30 numy = nyr if (mon == 0) then numy = nyr-1 mon = 12 endif !write(fn,'(a11,i3.3,a1,i3.3,a3)'),'../output/data',nyr,'_',n360,'.nc' write(fn,'(a15,i4.4,i2.2,a3)'),'../output/data_',numy,mon,'.nc' ierr=nfmpi_create(m_cart,fn,nf_64bit_offset,mpi_info_null,ncid) ierr=nfmpi_def_dim(ncid, "level-center", nn(1), kcid) ierr=nfmpi_def_dim(ncid, "level-face", nn(5), kfid) ierr=nfmpi_def_dim(ncid, "latitude", nn(2), jid) ierr=nfmpi_def_dim(ncid, "longitude", nn(3), iid) ierr=nfmpi_def_dim(ncid, "month", nn(4), mid) nda(3) = kcid nda(2) = jid nda(1) = iid ierr=nfmpi_def_var(ncid, "pressure", nf_double, 3, nda, idp) units='dyne/cm^2' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,idp,'units',length,trim(units)) long_name='Pressure' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,idp,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "u-velocity", nf_double, 3, nda, idu) units='cm/s' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,idu,'units',length,trim(units)) long_name='Zonal velocity' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,idu,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "v-velocity", nf_double, 3, nda, idv) units='cm/s' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,idv,'units',length,trim(units)) long_name='Meridional velocity' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,idv,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "temperature", nf_double, 3, nda, idt) units='degree C' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,idt,'units',length,trim(units)) long_name='Temperature' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,idt,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "salinity", nf_double, 3, nda, ids) units='psu (g/kg)' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,ids,'units',length,trim(units)) long_name='Salinity' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,ids,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "dmx", nf_double, 3, nda, idmx) units='cm^2/s' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,idmx,'units',length,trim(units)) long_name='Zonal turbulent viscosity' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,idmx,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "dmy", nf_double, 3, nda, idmy) units='cm^2/s' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,idmy,'units',length,trim(units)) long_name='Meridional turbulent viscosity' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,idmy,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "rho", nf_double, 3, nda, irho) units='g/cm^3' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,irho,'units',length,trim(units)) long_name='Density' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,irho,'long_name',length,trim(long_name)) !yc ierr=nfmpi_def_var(ncid, "cfc11", nf_double, 3, nda, idc) !yc ndc(3) = kfid ndc(2) = jid ndc(1) = iid ierr=nfmpi_def_var(ncid, "w-velocity", nf_double, 3, ndc, idw) units='cm/s' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,idw,'units',length,trim(units)) long_name='Vertical velocity' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,idw,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "hv", nf_double, 3, ndc, ihv) units='cm/s' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,ihv,'units',length,trim(units)) long_name='Vertical turbulent diffusivity' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,ihv,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "ev", nf_double, 3, ndc, iev) units='cm/s' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,iev,'units',length,trim(units)) long_name='Vertical turbulent viscosity' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,iev,'long_name',length,trim(long_name)) ndc(3) = mid ndc(2) = jid ndc(1) = iid ierr=nfmpi_def_var(ncid, "qavg", nf_double, 3, ndc, iqavg) ndb(2) = jid ndb(1) = iid ierr=nfmpi_def_var(ncid, "taux", nf_double, 2, ndb, ITX) units='dync/cm^2' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,ITX,'units',length,trim(units)) long_name='Zonal wind stress' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,ITX,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "tauy", nf_double, 2, ndb, ITY) units='dyne/cm^2' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,ITY,'units',length,trim(units)) long_name='Meridional wind stress' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,ITY,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "lath", nf_double, 2, ndb, ILH) units='Watt/m^2' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,ILH,'units',length,trim(units)) long_name='Latent heat flux' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,ILH,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "senh", nf_double, 2, ndb, ISH) units='Watt/m^2' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,ISH,'units',length,trim(units)) long_name='Sensible heat flux' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,ISH,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "qdot2", nf_double, 2, ndb, ISW) units='Watt/m^2' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,ISW,'units',length,trim(units)) long_name='Net short-wave radiation flux' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,ISW,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "qdot", nf_double, 2, ndb, ILW) units='Watt/m^2' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,ILW,'units',length,trim(units)) long_name='Total heat flux' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,ILW,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "evapo", nf_double, 2, ndb, IEVP) units='kg/m^2/s' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,IEVP,'units',length,trim(units)) long_name='Evaporation mass flux' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,IEVP,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "prec", nf_double, 2, ndb, IRA) units='kg/m^2/s' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,IRA,'units',length,trim(units)) long_name='Total precipitaion flux' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,IRA,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "kpp_src_t", nf_double, 3, NDA, IDKPPT) units='degree C /s' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,IDKPPT,'units',length,trim(units)) long_name='KPP temperature tendency' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,IDKPPT,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "kpp_src_s", nf_double, 3, NDA, IDKPPS) units='psu(g/kg) /s' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,IDKPPS,'units',length,trim(units)) long_name='KPP salinity tendency' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,IDKPPS,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "rain", nf_double, 2, ndb, Irain) units='kg/m^2/s' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,Irain,'units',length,trim(units)) long_name='rain-water mass flux' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,Irain,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "roff", nf_double, 2, ndb, Iroff) units='kg/m^2/s' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,Iroff,'units',length,trim(units)) long_name='River-runoff mass flux' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,Iroff,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "ioff", nf_double, 2, ndb, Iioff) units='kg/m^2/s' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,Iioff,'units',length,trim(units)) long_name='Ice-runoff mass flux' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,Iioff,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "melt", nf_double, 2, ndb, Imelt) units='kg/m^2/s' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,Imelt,'units',length,trim(units)) long_name='Snowmelt mass flux' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,Imelt,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "snow", nf_double, 2, ndb, Isnow) units='kg/m^2/s' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,Isnow,'units',length,trim(units)) long_name='Snow mass flux' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,Isnow,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "lwup", nf_double, 2, ndb, Ilwup) units='Watt/m^2' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,Ilwup,'units',length,trim(units)) long_name='Upward long-wave radiation heat flux' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,Ilwup,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "lwdn", nf_double, 2, ndb, Ilwdn) units='Watt/m^2' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,Ilwdn,'units',length,trim(units)) long_name='Downward long-wave radiation heat flux' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,Ilwdn,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "melth", nf_double, 2, ndb, Imelth) units='Watt/m^2' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,Imelth,'units',length,trim(units)) long_name='Ice and snowmelt heat flux' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,Imelth,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "snow_F", nf_double, 2, ndb, Isnowf) units='Watt/m^2' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,Isnowf,'units',length,trim(units)) long_name='Snowmelt heat flux' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,Isnowf,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "ioff_F", nf_double, 2, ndb, Iiofff) units='Watt/m^2' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,Iiofff,'units',length,trim(units)) long_name='Ice-runoff heat flux' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,Iiofff,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "virtsalt", nf_double, 2, ndb, Ivs) units='kg/m^2/s' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,Ivs,'units',length,trim(units)) long_name='Virtual salt mass flux' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,Ivs,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "qflx", nf_double, 2, ndb, Iqflx) units='Watt/m^2' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,Iqflx,'units',length,trim(units)) long_name='Total heat flux' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,Iqflx,'long_name',length,trim(long_name)) ierr=nfmpi_def_var(ncid, "hblt", nf_double, 2, ndb, Ihblt) units='cm' length=len(trim(units)) ierr=nfmpi_put_att_text(ncid,Ihblt,'units',length,trim(units)) long_name='Boundary layer depth' length=len(trim(long_name)) ierr=nfmpi_put_att_text(ncid,Ihblt,'long_name',length,trim(long_name)) ierr=nfmpi_enddef(ncid) call mtx2vec_c(pavg,in,rbf) ierr=nfmpi_put_vara_double_all(ncid, idp, ns_kji2, nc_kji2, rbf) call mtx2vec_c(uavg,in,rbf) ierr=nfmpi_put_vara_double_all(ncid, idu, ns_kji2, nc_kji2, rbf) call mtx2vec_c(vavg,in,rbf) ierr=nfmpi_put_vara_double_all(ncid, idv, ns_kji2, nc_kji2, rbf) call mtx2vec_c(tavg,in,rbf) ierr=nfmpi_put_vara_double_all(ncid, idt, ns_kji2, nc_kji2, rbf) call mtx2vec_c(savg,in,rbf) ierr=nfmpi_put_vara_double_all(ncid, ids, ns_kji2, nc_kji2, rbf) !yc call mtx2vec_c(cavg,in,rbf) ierr=nfmpi_put_vara_double_all(ncid, idc, ns_kji2, nc_kji2, rbf) !yc call mtx2vec_c(dmxavg,in,rbf) ierr=nfmpi_put_vara_double_all(ncid, idmx, ns_kji2, nc_kji2, rbf) call mtx2vec_c(dmyavg,in,rbf) ierr=nfmpi_put_vara_double_all(ncid, idmy, ns_kji2, nc_kji2, rbf) call mtx2vec_c(rhoavg,in,drbf) ierr=nfmpi_put_vara_double_all(ncid,irho,ns_kji2,nc_kji2,drbf) call mtx2vec_f(wcavg,iw,rbfw) ierr=nfmpi_put_vara_double_all(ncid, idw, ns_kji2, nf_kji2, rbfw) call mtx2vec_f(hvavg,iw,rbfw) ierr=nfmpi_put_vara_double_all(ncid, ihv, ns_kji2, nf_kji2, rbfw) call mtx2vec_f(evavg,iw,rbfw) ierr=nfmpi_put_vara_double_all(ncid, iev, ns_kji2, nf_kji2, rbfw) call mtx2rvec2(qavg,rmbf,i2,j2,i2,j2,12,0,0) ierr=nfmpi_put_vara_double_all(ncid, iqavg, ns_tji2, nc_tji2, rmbf) call mtx2rvec2(TAUXAVG,rmbf,I2,J2,I2,J2,1,0,0) ierr=nfmpi_put_vara_double_all(NCID, ITX, ns_tji2, nc_tji2, rmbf) call mtx2rvec2(TAUYAVG,rmbf,I2,J2,I2,J2,1,0,0) ierr=nfmpi_put_vara_double_all(NCID, ITY, ns_tji2, nc_tji2, rmbf) call mtx2rvec2(LATHAVG,rmbf,I2,J2,I2,J2,1,0,0) ierr=nfmpi_put_vara_double_all(NCID, ILH, ns_tji2, nc_tji2, rmbf) call mtx2rvec2(SENHAVG,rmbf,I2,J2,I2,J2,1,0,0) ierr=nfmpi_put_vara_double_all(NCID, ISH, ns_tji2, nc_tji2, rmbf) call mtx2rvec2(QDOT2AVG,rmbf,I2,J2,I2,J2,1,0,0) ierr=nfmpi_put_vara_double_all(NCID, ISW, ns_tji2, nc_tji2, rmbf) call mtx2rvec2(QDOTAVG,rmbf,I2,J2,I2,J2,1,0,0) ierr=nfmpi_put_vara_double_all(NCID, ILW, ns_tji2, nc_tji2, rmbf) call mtx2rvec2(EVAPOAVG,rmbf,I2,J2,I2,J2,1,0,0) ierr=nfmpi_put_vara_double_all(NCID, IEVP, ns_tji2, nc_tji2, rmbf) call mtx2rvec2(PRECAVG,rmbf,I2,J2,I2,J2,1,0,0) ierr=nfmpi_put_vara_double_all(NCID, IRA, ns_tji2, nc_tji2, rmbf) call mtx2vec_c(KPP_SRC_T,IN,drbf) ierr=nfmpi_put_vara_double_all(NCID, IDKPPT, ns_kji2, nc_kji2, drbf) call mtx2vec_c(KPP_SRC_S,IN,drbf) ierr=nfmpi_put_vara_double_all(NCID, IDKPPS, ns_kji2, nc_kji2, drbf) call mtx2rvec2(RAINAVG,rmbf,I2,J2,I2,J2,1,0,0) ierr=nfmpi_put_vara_double_all(NCID, Irain, ns_tji2, nc_tji2, rmbf) call mtx2rvec2(ROFFAVG,rmbf,I2,J2,I2,J2,1,0,0) ierr=nfmpi_put_vara_double_all(NCID, Iroff, ns_tji2, nc_tji2, rmbf) call mtx2rvec2(IOFFAVG,rmbf,I2,J2,I2,J2,1,0,0) ierr=nfmpi_put_vara_double_all(NCID, Iioff, ns_tji2, nc_tji2, rmbf) call mtx2rvec2(MELTAVG,rmbf,I2,J2,I2,J2,1,0,0) ierr=nfmpi_put_vara_double_all(NCID, Imelt, ns_tji2, nc_tji2, rmbf) call mtx2rvec2(SNOWAVG,rmbf,I2,J2,I2,J2,1,0,0) ierr=nfmpi_put_vara_double_all(NCID, Isnow, ns_tji2, nc_tji2, rmbf) call mtx2rvec2(LWUPAVG,rmbf,I2,J2,I2,J2,1,0,0) ierr=nfmpi_put_vara_double_all(NCID, Ilwup, ns_tji2, nc_tji2, rmbf) call mtx2rvec2(LWDNAVG,rmbf,I2,J2,I2,J2,1,0,0) ierr=nfmpi_put_vara_double_all(NCID, Ilwdn, ns_tji2, nc_tji2, rmbf) call mtx2rvec2(MELTHAVG,rmbf,I2,J2,I2,J2,1,0,0) ierr=nfmpi_put_vara_double_all(NCID, Imelth, ns_tji2, nc_tji2, rmbf) call mtx2rvec2(SNOWFAVG,rmbf,I2,J2,I2,J2,1,0,0) ierr=nfmpi_put_vara_double_all(NCID, Isnowf, ns_tji2, nc_tji2, rmbf) call mtx2rvec2(IOFFFAVG,rmbf,I2,J2,I2,J2,1,0,0) ierr=nfmpi_put_vara_double_all(NCID, Iiofff, ns_tji2, nc_tji2, rmbf) call mtx2rvec2(SALTAVG,rmbf,I2,J2,I2,J2,1,0,0) ierr=nfmpi_put_vara_double_all(NCID,Ivs, ns_tji2, nc_tji2, rmbf) call mtx2rvec2(QFLXAVG,rmbf,I2,J2,I2,J2,1,0,0) ierr=nfmpi_put_vara_double_all(NCID,Iqflx,ns_tji2, nc_tji2, rmbf) call mtx2rvec2(HBLTAVG,rmbf,I2,J2,I2,J2,1,0,0) ierr=nfmpi_put_vara_double_all(NCID,Ihblt,ns_ji2, nc_ji2, rmbf) call pnetcdferrck(ierr) ierr=nfmpi_close(ncid) CALL SETRD(PAVG,I0*J0*K1,0.d0) CALL SETRD(UAVG,I0*J0*K1,0.d0) CALL SETRD(VAVG,I0*J0*K1,0.d0) CALL SETRD(TAVG,I0*J0*K1,0.d0) CALL SETRD(SAVG,I0*J0*K1,0.d0) CALL SETRD(WCAVG,I0*J0*K0,0.d0) CALL SETRD(HVAVG,I0*J0*K0,0.d0) CALL SETRD(EVAVG,I0*J0*K0,0.d0) CALL SETRD(DMXAVG,I0*J0*K1,0.d0) CALL SETRD(DMYAVG,I0*J0*K1,0.d0) CALL SETRD(RHOAVG,I0*J0*K1,0.d0) CALL SETRD(TAUXAVG,I2*J2,0.d0) CALL SETRD(TAUYAVG,I2*J2,0.d0) CALL SETRD(LATHAVG,I2*J2,0.d0) CALL SETRD(SENHAVG,I2*J2,0.d0) CALL SETRD(QDOT2AVG,I2*J2,0.d0) CALL SETRD(QDOTAVG,I2*J2,0.d0) CALL SETRD(EVAPOAVG,I2*J2,0.d0) CALL SETRD(PRECAVG,I2*J2,0.d0) CALL SETRD(KPP_SRC_T,I0*J0*K1,0.d0) CALL SETRD(KPP_SRC_S,I0*J0*K1,0.d0) CALL SETRD(RAINAVG,I2*J2*1,0.d0) CALL SETRD(ROFFAVG,I2*J2*1,0.d0) CALL SETRD(IOFFAVG,I2*J2*1,0.d0) CALL SETRD(MELTAVG,I2*J2*1,0.d0) CALL SETRD(SNOWAVG,I2*J2*1,0.d0) CALL SETRD(LWUPAVG,I2*J2*1,0.d0) CALL SETRD(LWDNAVG,I2*J2*1,0.d0) CALL SETRD(MELTHAVG,I2*J2*1,0.d0) CALL SETRD(SNOWFAVG,I2*J2*1,0.d0) CALL SETRD(IOFFFAVG,I2*J2*1,0.d0) CALL SETRD(SALTAVG,I2*J2*1,0.d0) CALL SETRD(QFLXAVG,I2*J2*1,0.d0) CALL SETRD(HBLTAVG,I2*J2*1,0.d0) ! pavg = 0. ! uavg = 0. ! vavg = 0. ! tavg = 0. ! savg = 0. !yc ! cavg = 0. !yc ! wcavg = 0. ! hvavg = 0. ! evavg = 0. ! dmxavg= 0. ! dmyavg= 0. ! rhoavg= 0. ! tauxavg= 0. ! tauyavg= 0. ! lathabg= 0. ! senhavg= 0. ! qdot2avg= 0. ! qdotavg= 0. ! evapavg= 0. ! precavg= 0. ! kpp_src_t= 0. ! kpp_src_s= 0. ! rainavg= 0. ! roffavg= 0. ! ioffavg= 0. ! meltavg= 0. ! snowavg= 0. ! lwupavg= 0. ! lwdnavg= 0. ! meltHavg= 0. ! snowFavg= 0. ! ioffFavg= 0. ! saltavg= 0. ! qflxavg= 0. ! hbltavg= 0. end subroutine ! ---------------------------------------------------------------------- subroutine write_topo parameter(i01=i0+1,j01=j0+1,nbg0=nb0*ngy0,nbg1=nbg0-1,ibir=i2t/ngy0) character fn*17 integer*2 nbf common/windsglo/taux(i2,j2,12),tauy(i2,j2,12) dimension z_c(k1),z_f(k0),nda(3),ndb(3),ndc(3),ndd(4),ndw(3) integer(kind=mpi_offset_kind) st_z,ct_z,nss(4),nee(4),nws(3),nwe(3),nks(2),nke(2) dimension xlon(i2),ylat(j2) dimension wbf(i2*j2),sbf(i2*j2*k1),rbf(i2*j2*12),vbf(i2*j2*k1*12) dimension inf(i2*j2*k1),iwf(i2*j2*k0),kbf(i2*j2) fn='../output/topo.nc' do 999 j=1,j2 999 ylat(j)=ydeg(j+1) do 1000 i=1,i2 1000 xlon(i)=xdeg(i+1) do 1001 k=1,k1 1001 z_c(k)=z(2*k) do 1002 k=1,k0 1002 z_f(k)=z(1+2*(k-1)) ierr=nfmpi_create(m_cart,fn,nf_64bit_offset,mpi_info_null,ncid) ierr=nfmpi_def_dim(ncid, "level-center", nn(1), kcid) ierr=nfmpi_def_dim(ncid, "level-face", nn(5), kfid) ierr=nfmpi_def_dim(ncid, "latitude", nn(2), jid) ierr=nfmpi_def_dim(ncid, "longitude", nn(3), iid) ierr=nfmpi_def_dim(ncid, "month", nn(4), mid) ierr=nfmpi_def_var(ncid, "lev_c", nf_double, 1, kcid, izc) ierr=nfmpi_def_var(ncid, "lev_f", nf_double, 1, kfid, izf) ierr=nfmpi_def_var(ncid, "lat", nf_double, 1, jid, iyd) ierr=nfmpi_def_var(ncid, "lon", nf_double, 1, iid, ixd) nda(1)=iid nda(2)=jid ierr=nfmpi_def_var(ncid, "s_nudge", nf_double, 2, nda, isn) ierr=nfmpi_def_var(ncid, "t_nudge", nf_double, 2, nda, itn) ndb(1)=iid ndb(2)=jid ndb(3)=kcid ierr=nfmpi_def_var(ncid, "hmean_nudge", nf_double, 3, ndb, ihn) ndc(1)=iid ndc(2)=jid ndc(3)=mid ierr=nfmpi_def_var(ncid, "taux", nf_double, 3, ndc, itx) ierr=nfmpi_def_var(ncid, "tauy", nf_double, 3, ndc, ity) ndd(1)=iid ndd(2)=jid ndd(3)=kcid ndd(4)=mid ierr=nfmpi_def_var(ncid, "sclis", nf_double, 4, ndd, isc) ierr=nfmpi_def_var(ncid, "tclis", nf_double, 4, ndd, itc) ierr=nfmpi_def_var(ncid, "kb", nf_int, 2, ndb, iik) ierr=nfmpi_def_var(ncid, "mask", nf_int,3, ndb, iin) ndw(1)=iid ndw(2)=jid ndw(3)=kfid ierr=nfmpi_def_var(ncid, "mask_w", nf_int,3, ndw, iiw) ierr=nfmpi_enddef(ncid) ! z! zf ydeg xdeg st_z=1 ct_z = k1 ierr=nfmpi_put_vara_double_all(ncid,izc,st_z,ct_z,z_c) ct_z = k0 ierr=nfmpi_put_vara_double_all(ncid,izf,st_z,ct_z,z_f) ierr=nfmpi_put_vara_double_all(ncid,iyd,ns_kji(2),nc_kji(2),ylat) ierr=nfmpi_put_vara_double_all(ncid,ixd,ns_kji(3),nc_kji(3),xlon) ! s_nudge t_nudge hmean_nudge call mtx2rvec2(s_nudge,wbf,i0,j0,i2,j2,1,1,1) ierr=nfmpi_put_vara_double_all(ncid, isn, ns_ji2,nc_ji2,wbf) call mtx2rvec2(t_nudge,wbf,i0,j0,i2,j2,1,1,1) ierr=nfmpi_put_vara_double_all(ncid, itn, ns_ji2, nc_ji2,wbf) call mtx2rvec2(hmean_nudge,sbf,i0,j0,i2,j2,k1,1,1) ierr=nfmpi_put_vara_double_all(ncid, ihn, ns_kji2, nc_kji2,sbf) ! taux tauy call mtx2rvec2(taux,rbf,i2,j2,i2,j2,12,0,0) ierr=nfmpi_put_vara_double_all(ncid, itx, ns_tji2, nc_tji2, rbf) call mtx2rvec2(tauy,rbf,i2,j2,i2,j2,12,0,0) ierr=nfmpi_put_vara_double_all(ncid, ity, ns_tji2, nc_tji2, rbf) ! sclis tclis nss(4)=ns_tji(1) nss(3)=ns_kji(1) nss(2)=ns_tji(2) nss(1)=ns_tji(3) nee(4)=nc_tji(1) nee(3)=nc_kji(1) nee(2)=nc_tji(2) nee(1)=nc_tji(3) call mtx2rvec_m(sclis,vbf,i0,j0,k1,i2,j2,k1,12,1,1) ierr=nfmpi_put_vara_double_all(ncid,isc,nss,nee,vbf) call mtx2rvec_m(tclis,vbf,i0,j0,k1,i2,j2,k1,12,1,1) ierr=nfmpi_put_vara_double_all(ncid,itc,nss,nee,vbf) ! kb in iw nks(1)=ns_kji2(1) nks(2)=ns_kji2(2) nke(1)=nc_kji2(1) nke(2)=nc_kji2(2) call mtx2ivec(kb,kbf,i0,j0,i2,j2,1,1,1) ierr=nfmpi_put_vara_int_all(ncid,iik,ns_kji2,nc_kji2,kbf) call mtx2ivec(in,inf,i0,j0,i2,j2,k1,1,1) ierr=nfmpi_put_vara_int_all(ncid,iin,ns_kji2,nc_kji2,inf) nws(3)=ns_kji(1) nws(2)=ns_kji(2) nws(1)=ns_kji(3) nwe(3)=nn(5) nwe(2)=nc_kji(2) nwe(1)=nc_kji(3) call mtx2ivec(iw,iwf,i0,j0,i2,j2,k0,1,1) ierr=nfmpi_put_vara_int_all(ncid,iiw,nws,nwe,iwf) ierr=nfmpi_close(ncid) end subroutine ! ---------------------------------------------------------------------- subroutine write_rerun parameter(nbg0=nb0*ngy0,nbg1=nbg0-1,i01=i0+1,ibir=i2t/ngy0,j01=j0+1) character fn*17 integer*2 nbf real*8 dbf dimension dbf(i2*j2) dimension wbf(i2*j2*k0) dimension nd(4) ! write(*,'(a20,12i3)') 'kilmer:nsombo=', nsombo ierr=nfmpi_create(m_cart,'data/rerun.nc',nf_64bit_offset,mpi_info_null,ncid) call pnetcdferrck(ierr) ierr=nfmpi_def_dim(ncid, "latitude", nn(2), idj) ierr=nfmpi_def_dim(ncid, "longitude", nn(3), idi) ierr=nfmpi_def_dim(ncid, "month", nn(4), idt) ierr=nfmpi_def_dim(ncid, "global" , nn(6), id1) call pnetcdferrck(ierr) nd(1)=id1 ierr=nfmpi_def_var(ncid, "itf", nf_int, 1, nd, i_itf) ierr=nfmpi_def_var(ncid, "days", nf_double, 1, nd, i_days) ierr=nfmpi_def_var(ncid, "evap", nf_double, 1, nd, i_evap) ierr=nfmpi_def_var(ncid, "qsum", nf_double, 1, nd, i_qsum) ierr=nfmpi_def_var(ncid, "olde", nf_double, 1, nd, i_olde) ierr=nfmpi_def_var(ncid, "oldq", nf_double, 1, nd, i_oldq) nd(1)=idt ierr=nfmpi_def_var(ncid, "nsombo", nf_int, 1, nd, i_nsombo) nd(1)=idj nd(2)=idi ierr=nfmpi_def_var(ncid, "x", nf_double, 2, nd, ix) ! ierr=nfmpi_def_var(ncid, "fsf", nf_double, 2, nd, ifsf) ierr=nfmpi_def_var(ncid, "p0", nf_double, 2, nd, ip0) nd(1)=idt nd(2)=idj nd(3)=idi ierr=nfmpi_def_var(ncid, "qvag", nf_double, 3, nd, iqavg) nd(1)=idj nd(2)=idi ierr=nfmpi_def_var(ncid, "tnudge", nf_double, 2, nd, itnudge) ierr=nfmpi_def_var(ncid, "pbar", nf_double, 2, nd, ipbar) ierr=nfmpi_def_var(ncid, "pvar", nf_double, 2, nd, ipvar) ierr=nfmpi_def_var(ncid, "xbar", nf_double, 2, nd, ixbar) ierr=nfmpi_def_var(ncid, "ucli", nf_double, 2, nd, iucli) ierr=nfmpi_def_var(ncid, "vcli", nf_double, 2, nd, ivcli) ierr=nfmpi_def_var(ncid, "rmsv", nf_double, 2, nd, irmsv) ierr=nfmpi_enddef(ncid) ierr=nfmpi_put_vara_int_all(ncid, i_itf, ns_1, nc_1, itf) ierr=nfmpi_put_vara_double_all(ncid, i_days, ns_1, nc_1, days) ierr=nfmpi_put_vara_double_all(ncid, i_evap, ns_1, nc_1, evap) ierr=nfmpi_put_vara_double_all(ncid, i_qsum, ns_1, nc_1, qsum) ierr=nfmpi_put_vara_double_all(ncid, i_olde, ns_1, nc_1, olde) ierr=nfmpi_put_vara_double_all(ncid, i_oldq, ns_1, nc_1, oldq) ierr=nfmpi_put_vara_int_all(ncid, i_nsombo, ns_tji(1), nc_tji(1), nsombo) call mtx2dvec(x,dbf) ierr=nfmpi_put_vara_double_all(ncid,ix,ns_ji,nc_ji,dbf) ! call mtx2rvec(fsf,wbf,i0,j0,i2,j2,1,1,1) ! ierr=nfmpi_put_vara_double_all(ncid, ifsf, ns_ji, nc_ji, wbf) call mtx2rvec(p0,wbf,i0,j0,i2,j2,1,1,1) ierr=nfmpi_put_vara_double_all(ncid, ip0, ns_ji, nc_ji, wbf) call mtx2rvec(qavg,wbf,i2,j2,i2,j2,12,0,0) ierr=nfmpi_put_vara_double_all(ncid, iqavg, ns_tji, nc_tji, wbf) call mtx2rvec(tnudge,wbf,i2,j2,i2,j2,1,0,0) ierr=nfmpi_put_vara_double_all(ncid, itnudge, ns_ji, nc_ji, wbf) call mtx2rvec(pbar,wbf,i0,j0,i2,j2,1,1,1) ierr=nfmpi_put_vara_double_all(ncid, ipbar, ns_ji, nc_ji, wbf) call mtx2rvec(pvar,wbf,i0,j0,i2,j2,1,1,1) ierr=nfmpi_put_vara_double_all(ncid, ipvar, ns_ji, nc_ji, wbf) call mtx2rvec(xbar,wbf,i0,j0,i2,j2,1,1,1) ierr=nfmpi_put_vara_double_all(ncid, ixbar, ns_ji, nc_ji, wbf) call mtx2rvec(ucli,wbf,i0,j0,i2,j2,1,1,1) ierr=nfmpi_put_vara_double_all(ncid, iucli, ns_ji, nc_ji, wbf) call mtx2rvec(vcli,wbf,i0,j0,i2,j2,1,1,1) ierr=nfmpi_put_vara_double_all(ncid, ivcli, ns_ji, nc_ji, wbf) call mtx2rvec(rmsv,wbf,i0,j0,i2,j2,1,1,1) ierr=nfmpi_put_vara_double_all(ncid, irmsv, ns_ji, nc_ji, wbf) ierr=nfmpi_close(ncid) call write2nc('u1','u1',u1,k1,1) call write2nc('u2','u2',u2,k1,1) call write2nc('ul','ulf',ulf,k1,1) call write2nc('v1','v1',v1,k1,1) call write2nc('v2','v2',v2,k1,1) call write2nc('vl','vlf',vlf,k1,1) call write2nc('t1','t1',t1,k1,1) call write2nc('t2','t2',t2,k1,1) call write2nc('tl','tlf',tlf,k1,1) call write2nc('s1','s1',s1,k1,1) call write2nc('s2','s2',s2,k1,1) call write2nc('sl','slf',slf,k1,1) call write2nc('pp','p',p,k1,1) call write2nc('uc','u',u,k1,1) call write2nc('wc','w',w,k0,5) call write2nc('vc','v',v,k1,1) !yc call write2nc('c1','c1',c1,k1,1) call write2nc('c2','c2',c2,k1,1) call write2nc('cl','clf',clf,k1,1) !yc end subroutine ! ---------------------------------------------------------------------- subroutine read_gas(fice,xkw,patm) ! dimension fice(i2,j2,12),xkw(i2,j2,12),patm(i2,j2,12) parameter(nbg0=nb0*ngy0,nbg1=nbg0-1,i01=i0+1,ibir=i2t/ngy0,j01=j0+1) dimension rrbf(i2*j2*12) real*8 :: rrbf ! ierr=nfmpi_open(m_cart,'data/timcom_gasx.nc',nf_nowrite,mpi_info_null,ncid) call pnetcdferrck(ierr) ! ierr=nfmpi_inq_varid(ncid, "fice", itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_tji,nc_tji,rrbf) call pnetcdferrck(ierr) call rvec2mtx(fice,rrbf,i2,j2,i2,j2,12,0,0) ! ierr=nfmpi_inq_varid(ncid, "xkw", itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_tji,nc_tji,rrbf) call pnetcdferrck(ierr) call rvec2mtx(xkw,rrbf,i2,j2,i2,j2,12,0,0) ! ierr=nfmpi_inq_varid(ncid, "patm", itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_tji,nc_tji,rrbf) call pnetcdferrck(ierr) call rvec2mtx(patm,rrbf,i2,j2,i2,j2,12,0,0) ! end subroutine ! ---------------------------------------------------------------------- ! ---------------------------------------------------------------------- subroutine read_rerun parameter(nbg0=nb0*ngy0,nbg1=nbg0-1,i01=i0+1,ibir=i2t/ngy0,j01=j0+1) character fn*17 integer*2 nbf real*8 dbf dimension dbf(i2*j2) dimension rbf(i2*j2*k0),rrbf(i2*j2*12) dimension nd(4) ierr=nfmpi_open(m_cart,'data/rerun.nc',nf_nowrite,mpi_info_null,ncid) call pnetcdferrck(ierr) ierr=nfmpi_inq_varid(ncid, "itf", itmp) ierr=nfmpi_get_var_int_all(ncid, itmp, itf) call pnetcdferrck(ierr) ierr=nfmpi_inq_varid(ncid, "days", itmp) ierr=nfmpi_get_var_double_all(ncid, itmp, days) call pnetcdferrck(ierr) ierr=nfmpi_inq_varid(ncid, "evap", itmp) ierr=nfmpi_get_var_double_all(ncid, itmp, evap) call pnetcdferrck(ierr) ierr=nfmpi_inq_varid(ncid, "qsum", itmp) ierr=nfmpi_get_var_double_all(ncid, itmp, qsum) call pnetcdferrck(ierr) ierr=nfmpi_inq_varid(ncid, "olde", itmp) ierr=nfmpi_get_var_double_all(ncid, itmp, olde) call pnetcdferrck(ierr) ierr=nfmpi_inq_varid(ncid, "oldq", itmp) ierr=nfmpi_get_var_double_all(ncid, itmp, oldq) call pnetcdferrck(ierr) ierr=nfmpi_inq_varid(ncid, "nsombo", itmp) ierr=nfmpi_get_vara_int_all(ncid,itmp,ns_tji(1),nc_tji(1),nsombo) call pnetcdferrck(ierr) ierr=nfmpi_inq_varid(ncid, "x", itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_ji,nc_ji,dbf) call pnetcdferrck(ierr) call dvec2mtx(x,dbf) ! ierr=nfmpi_inq_varid(ncid, "fsf", itmp) ! ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_ji,nc_ji,rbf) ! call rvec2mtx(fsf,rbf,i0,j0,i2,j2,1,1,1) ierr=nfmpi_inq_varid(ncid, "p0", itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_ji,nc_ji,rbf) call pnetcdferrck(ierr) call rvec2mtx(p0,rbf,i0,j0,i2,j2,1,1,1) ierr=nfmpi_inq_varid(ncid, "qvag", itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_tji,nc_tji,rrbf) call pnetcdferrck(ierr) call rvec2mtx(qavg,rrbf,i2,j2,i2,j2,12,0,0) ierr=nfmpi_inq_varid(ncid, "tnudge", itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_ji,nc_ji,rbf) call pnetcdferrck(ierr) call rvec2mtx(tnudge,rbf,i2,j2,i2,j2,1,0,0) ierr=nfmpi_inq_varid(ncid, "pbar", itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_ji,nc_ji,rbf) call pnetcdferrck(ierr) call rvec2mtx(pbar,rbf,i0,j0,i2,j2,1,1,1) ierr=nfmpi_inq_varid(ncid, "pvar", itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_ji,nc_ji,rbf) call pnetcdferrck(ierr) call rvec2mtx(pvar,rbf,i0,j0,i2,j2,1,1,1) ierr=nfmpi_inq_varid(ncid, "xbar", itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_ji,nc_ji,rbf) call pnetcdferrck(ierr) call rvec2mtx(xbar,rbf,i0,j0,i2,j2,1,1,1) ierr=nfmpi_inq_varid(ncid, "ucli", itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_ji,nc_ji,rbf) call pnetcdferrck(ierr) call rvec2mtx(ucli,rbf,i0,j0,i2,j2,1,1,1) ierr=nfmpi_inq_varid(ncid, "vcli", itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_ji,nc_ji,rbf) call pnetcdferrck(ierr) call rvec2mtx(vcli,rbf,i0,j0,i2,j2,1,1,1) ierr=nfmpi_inq_varid(ncid, "rmsv", itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_ji,nc_ji,rbf) call pnetcdferrck(ierr) call rvec2mtx(rmsv,rbf,i0,j0,i2,j2,1,1,1) ierr=nfmpi_close(ncid) call pnetcdferrck(ierr) call readnc('u1','u1',u1,k1) call readnc('u2','u2',u2,k1) call readnc('ul','ulf',ulf,k1) call readnc('v1','v1',v1,k1) call readnc('v2','v2',v2,k1) call readnc('vl','vlf',vlf,k1) call readnc('t1','t1',t1,k1) call readnc('t2','t2',t2,k1) call readnc('tl','tlf',tlf,k1) call readnc('s1','s1',s1,k1) call readnc('s2','s2',s2,k1) call readnc('sl','slf',slf,k1) call readnc('pp','p',p,k1) call readnc('uc','u',u,k1) call readnc('wc','w',w,k0) call readnc('vc','v',v,k1) !yc call readnc('c1','c1',c1,k1) call readnc('c2','c2',c2,k1) call readnc('cl','clf',clf,k1) !yc call mpi_sendrecv(u(i1,1,1),1,m_vlon,m_e,1,u(1,1,1),1,m_vlon,m_w,1,m_cart,istat,ierr) call mpi_sendrecv(v(1,j1,1),1,m_vlat,m_n,1,v(1,1,1),1,m_vlat,m_s,1,m_cart,istat,ierr) end subroutine ! ------------------------------------------------------------- subroutine write_init2nc(stm,ttm) dimension stm(i0,j0,k1),ttm(i0,j0,k1),wbf(i2*j2*k1),nd(3) ierr=nfmpi_create(m_cart,'data/initial.nc',nf_64bit_offset,mpi_info_null,ncid) call pnetcdferrck(ierr) ierr=nfmpi_def_dim(ncid, "level", nn(1), idk) ierr=nfmpi_def_dim(ncid, "latitude", nn(2), idj) ierr=nfmpi_def_dim(ncid, "longitude", nn(3), idi) call pnetcdferrck(ierr) nd(1)=idk nd(2)=idj nd(3)=idi ierr=nfmpi_def_var(ncid, 'ti', nf_double, 3, nd, itmp) ierr=nfmpi_def_var(ncid, 'si', nf_double, 3, nd, ismp) ierr=nfmpi_enddef(ncid) ! for temperature l=1 do 100 i=2,i1 do 100 j=2,j1 do 100 k=1,k1 wbf(l)=ttm(i,j,k) 100 l=l+1 nc_kji(1)=k1 ierr=nfmpi_put_vara_double_all(ncid, itmp, ns_kji, nc_kji, wbf) call pnetcdferrck(ierr) ! for salinity l=1 do 101 i=2,i1 do 101 j=2,j1 do 101 k=1,k1 wbf(l)=stm(i,j,k) 101 l=l+1 ierr=nfmpi_put_vara_double_all(ncid, ismp, ns_kji, nc_kji, wbf) ierr=nfmpi_close(ncid) end subroutine ! ---------------------------------------------------------------------- subroutine initbred parameter(nbg0=nb0*ngy0,nbg1=nbg0-1,i01=i0+1,ibir=i2t/ngy0,j01=j0+1) character fn*17,filename*30 real*8 dbf dimension dbf(i2*j2) dimension rbf(i2*j2*k0),rrbf(i2*j2*12) dimension nd(4) dimension ub(i0,j0,k1),vb(i0,j0,k1) jt=mylat*j2 it=mylon*i2 do 50 j=1,j2 do 50 i=1,i2 ibred(i,j)=0 50 if (((it+i.ge.540).and.(it+i).le.720).and.((jt+j.ge.524).and.(jt+j).le.572))ibred(i,j)=1 do 100 k=1,30 do 100 j=2,j1 do 100 i=2,i1 ub(i,j,k)=u1(i,j,k) 100 vb(i,j,k)=v1(i,j,k) call readnc('u1','u1',u1,k1) call readnc('v1','v1',v1,k1) call readnc('t1','t1',t1,k1) call readnc('s1','s1',s1,k1) bf=0. eke=0. tmp=0. do 150 k=1,30 do 150 j=2,j1 do 150 i=2,i1 ub(i,j,k)=ibred(i-1,j-1)*(ub(i,j,k)-u1(i,j,k)) vb(i,j,k)=ibred(i-1,j-1)*(vb(i,j,k)-v1(i,j,k)) temp=in(i,j,k)*(ub(i,j,k)*ub(i,j,k)+vb(i,j,k)*vb(i,j,k)) 150 tmp=tmp+temp call mpi_allreduce(tmp,temp,1,mpi_real8,mpi_sum,m_cart,ierr) bf1=sqrt(temp) if (myid .eq. 0) print*,'bred ke1 factor =',bf1,'bred ke1 = ',temp do 200 k=1,30 do 200 j=2,j1 do 200 i=2,i1 ub(i,j,k)=u2(i,j,k) 200 vb(i,j,k)=v2(i,j,k) call readnc('u2','u2',u2,k1) call readnc('v2','v2',v2,k1) call readnc('t2','t2',t2,k1) call readnc('s2','s2',s2,k1) bf=0. eke=0. tmp=0. do 250 k=1,30 do 250 j=2,j1 do 250 i=2,i1 ub(i,j,k)=ibred(i-1,j-1)*(ub(i,j,k)-u2(i,j,k)) vb(i,j,k)=ibred(i-1,j-1)*(vb(i,j,k)-v2(i,j,k)) temp=in(i,j,k)*(ub(i,j,k)*ub(i,j,k)+vb(i,j,k)*vb(i,j,k)) 250 tmp=tmp+temp call mpi_allreduce(tmp,temp,1,mpi_real8,mpi_sum,m_cart,ierr) bf2=sqrt(temp) if (myid .eq. 0) print*,'bred ke2 factor =',bf2,'bred ke2 = ',temp do 300 k=1,30 do 300 j=2,j1 do 300 i=2,i1 ub(i,j,k)=ulf(i,j,k) 300 vb(i,j,k)=vlf(i,j,k) call readnc('ul','ulf',ulf,k1) call readnc('vl','vlf',vlf,k1) call readnc('tl','tlf',tlf,k1) call readnc('sl','slf',slf,k1) bf=0. eke=0. tmp=0. do 350 k=1,30 do 350 j=2,j1 do 350 i=2,i1 ub(i,j,k)=ibred(i-1,j-1)*(ub(i,j,k)-ulf(i,j,k)) vb(i,j,k)=ibred(i-1,j-1)*(vb(i,j,k)-vlf(i,j,k)) temp=in(i,j,k)*(ub(i,j,k)*ub(i,j,k)+vb(i,j,k)*vb(i,j,k)) 350 tmp=tmp+temp call mpi_allreduce(tmp,temp,1,mpi_real8,mpi_sum,m_cart,ierr) bflf=sqrt(temp) if (myid .eq. 0)print*,'bred kelf factor =',bflf,'bred kelf = ',temp end subroutine ! ---------------------------------------------------------------------- subroutine rescbred parameter(nbg0=nb0*ngy0,nbg1=nbg0-1,i01=i0+1,ibir=i2t/ngy0,j01=j0+1) character fn*17,filename*30 real*8 dbf dimension dbf(i2*j2) dimension rbf(i2*j2*k0),rrbf(i2*j2*12) dimension nd(4) dimension ub(i0,j0,k1),vb(i0,j0,k1),tb(i0,j0,k1),sb(i0,j0,k1) do 100 k=1,30 do 100 j=2,j1 do 100 i=2,i1 ub(i,j,k)=u1(i,j,k) vb(i,j,k)=v1(i,j,k) tb(i,j,k)=t1(i,j,k) 100 sb(i,j,k)=s1(i,j,k) call readnc('u1','u1',u1,k1) call readnc('v1','v1',v1,k1) call readnc('t1','t1',t1,k1) call readnc('s1','s1',s1,k1) tmp=0. do 130 k=1,30 do 130 j=2,j1 do 130 i=2,i1 ub(i,j,k)=ibred(i-1,j-1)*(ub(i,j,k)-u1(i,j,k)) vb(i,j,k)=ibred(i-1,j-1)*(vb(i,j,k)-v1(i,j,k)) tb(i,j,k)=ibred(i-1,j-1)*(tb(i,j,k)-t1(i,j,k)) sb(i,j,k)=ibred(i-1,j-1)*(sb(i,j,k)-s1(i,j,k)) temp=in(i,j,k)*(ub(i,j,k)*ub(i,j,k)+vb(i,j,k)*vb(i,j,k)) 130 tmp=tmp+temp call mpi_allreduce(tmp,temp,1,mpi_real8,mpi_sum,m_cart,ierr) tp=bf1/sqrt(temp) temp=0. do 160 k=1,30 do 160 j=2,j1 do 160 i=2,i1 temp=temp+in(i,j,k)*ibred(i-1,j-1)*ub(i,j,k)*ub(i,j,k) temp=temp+in(i,j,k)*ibred(i-1,j-1)*vb(i,j,k)*vb(i,j,k) u1(i,j,k)=u1(i,j,k)+in(i,j,k)*ub(i,j,k)*tp v1(i,j,k)=v1(i,j,k)+in(i,j,k)*vb(i,j,k)*tp t1(i,j,k)=t1(i,j,k)+in(i,j,k)*tb(i,j,k)*tp 160 s1(i,j,k)=s1(i,j,k)+in(i,j,k)*sb(i,j,k)*tp call mpi_allreduce(temp,tmp,1,mpi_real8,mpi_sum,m_cart,ierr) if (myid .eq. 0) print*,'bred ke1 factor =',tp,'bred ke1 = ',tmp do 200 k=1,30 do 200 j=2,j1 do 200 i=2,i1 ub(i,j,k)=u2(i,j,k) vb(i,j,k)=v2(i,j,k) tb(i,j,k)=t2(i,j,k) 200 sb(i,j,k)=s2(i,j,k) call readnc('u2','u2',u2,k1) call readnc('v2','v2',v2,k1) call readnc('t2','t2',t2,k1) call readnc('s2','s2',s2,k1) tmp=0. do 230 k=1,30 do 230 j=2,j1 do 230 i=2,i1 ub(i,j,k)=ibred(i-1,j-1)*(ub(i,j,k)-u2(i,j,k)) vb(i,j,k)=ibred(i-1,j-1)*(vb(i,j,k)-v2(i,j,k)) tb(i,j,k)=ibred(i-1,j-1)*(tb(i,j,k)-t2(i,j,k)) sb(i,j,k)=ibred(i-1,j-1)*(sb(i,j,k)-s2(i,j,k)) temp=in(i,j,k)*(ub(i,j,k)*ub(i,j,k)+vb(i,j,k)*vb(i,j,k)) 230 tmp=tmp+temp call mpi_allreduce(tmp,temp,1,mpi_real8,mpi_sum,m_cart,ierr) tp=bf2/sqrt(temp) temp=0. do 260 k=1,30 do 260 j=2,j1 do 260 i=2,i1 temp=temp+in(i,j,k)*ibred(i-1,j-1)*ub(i,j,k)*ub(i,j,k) temp=temp+in(i,j,k)*ibred(i-1,j-1)*vb(i,j,k)*vb(i,j,k) u2(i,j,k)=u2(i,j,k)+in(i,j,k)*ub(i,j,k)*tp v2(i,j,k)=v2(i,j,k)+in(i,j,k)*vb(i,j,k)*tp t2(i,j,k)=t2(i,j,k)+in(i,j,k)*tb(i,j,k)*tp 260 s2(i,j,k)=s2(i,j,k)+in(i,j,k)*sb(i,j,k)*tp call mpi_allreduce(temp,tmp,1,mpi_real8,mpi_sum,m_cart,ierr) if (myid .eq. 0) print*,'bred ke2 factor =',tp,'bred ke2 = ',tmp do 300 k=1,30 do 300 j=2,j1 do 300 i=2,i1 ub(i,j,k)=ulf(i,j,k) vb(i,j,k)=vlf(i,j,k) tb(i,j,k)=tlf(i,j,k) 300 sb(i,j,k)=slf(i,j,k) call readnc('ul','ulf',ulf,k1) call readnc('vl','vlf',vlf,k1) call readnc('tl','tlf',tlf,k1) call readnc('sl','slf',slf,k1) tmp=0. do 330 k=1,30 do 330 j=2,j1 do 330 i=2,i1 ub(i,j,k)=ibred(i-1,j-1)*(ub(i,j,k)-ulf(i,j,k)) vb(i,j,k)=ibred(i-1,j-1)*(vb(i,j,k)-vlf(i,j,k)) tb(i,j,k)=ibred(i-1,j-1)*(tb(i,j,k)-tlf(i,j,k)) sb(i,j,k)=ibred(i-1,j-1)*(sb(i,j,k)-slf(i,j,k)) temp=in(i,j,k)*(ub(i,j,k)*ub(i,j,k)+vb(i,j,k)*vb(i,j,k)) 330 tmp=tmp+temp call mpi_allreduce(tmp,temp,1,mpi_real8,mpi_sum,m_cart,ierr) tp=bflf/sqrt(temp) temp=0. do 360 k=1,30 do 360 j=2,j1 do 360 i=2,i1 temp=temp+in(i,j,k)*ibred(i-1,j-1)*ub(i,j,k)*ub(i,j,k) temp=temp+in(i,j,k)*ibred(i-1,j-1)*vb(i,j,k)*vb(i,j,k) ulf(i,j,k)=ulf(i,j,k)+in(i,j,k)*ub(i,j,k)*tp vlf(i,j,k)=vlf(i,j,k)+in(i,j,k)*vb(i,j,k)*tp tlf(i,j,k)=tlf(i,j,k)+in(i,j,k)*tb(i,j,k)*tp 360 slf(i,j,k)=slf(i,j,k)+in(i,j,k)*sb(i,j,k)*tp call mpi_allreduce(temp,tmp,1,mpi_real8,mpi_sum,m_cart,ierr) if (myid .eq. 0) print*,'bred kel factor =',tp,'bred kel = ',tmp end subroutine ! ---------------------------------------------------------------------- subroutine write2nc(fn,vn,fld,l0,nl) parameter(nbg0=nb0*ngy0,nbg1=nbg0-1,i01=i0+1,ibir=i2t/ngy0,j01=j0+1) character fn*(*),vn*(*),filename*10 dimension fld(i0,j0,l0),wbf(i2*j2*l0),nd(3) write(filename,'(a5,a2,a3)'),'data/',fn,'.nc' ierr=nfmpi_create(m_cart,filename,nf_64bit_offset,mpi_info_null,ncid) if (ierr .ne. 0) print*,fn,nfmpi_strerror(ierr) if (nl .eq. 1) then ierr=nfmpi_def_dim(ncid, "level", nn(1), idk) else ierr=nfmpi_def_dim(ncid, "level", nn(nl), idk) endif ierr=nfmpi_def_dim(ncid, "latitude", nn(2), idj) ierr=nfmpi_def_dim(ncid, "longitude", nn(3), idi) nd(1)=idk nd(2)=idj nd(3)=idi ierr=nfmpi_def_var(ncid, vn, nf_double, 3, nd, itmp) if (ierr .ne. 0) print*,fn,nfmpi_strerror(ierr) ierr=nfmpi_enddef(ncid) if (ierr .ne. 0) print*,fn,nfmpi_strerror(ierr) l=1 do 100 i=2,i1 do 100 j=2,j1 do 100 k=1,l0 wbf(l)=fld(i,j,k) 100 l=l+1 nc_kji(1)=l0 ierr=nfmpi_put_vara_double_all(ncid, itmp, ns_kji, nc_kji, wbf) if (ierr .ne. 0) print*,fn,nfmpi_strerror(ierr) ierr=nfmpi_close(ncid) if (ierr .ne. 0) print*,fn,nfmpi_strerror(ierr) end subroutine ! ------------------------------------------------------------- subroutine read_initnc(stm,ttm) dimension stm(i0,j0,k1),ttm(i0,j0,k1),rbf(i2*j2*k1),nd(3) ierr=nfmpi_open(m_cart,'data/initial.nc',nf_nowrite,mpi_info_null,ncid) if(ierr.ne.0)then call pnetcdferrck(ierr) call mpi_finalize(ierr) stop endif ierr=nfmpi_inq_varid(ncid,'ti',itmp) nc_kji(1)=k1 ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_kji,nc_kji,rbf) call pnetcdferrck(ierr) l=1 do 11 i=2,i1 do 11 j=2,j1 do 11 k=1,k1 ttm(i,j,k)=rbf(l) 11 l=l+1 ierr=nfmpi_inq_varid(ncid,'si',ismp) ierr=nfmpi_get_vara_double_all(ncid,ismp,ns_kji,nc_kji,rbf) call pnetcdferrck(ierr) l=1 do 12 i=2,i1 do 12 j=2,j1 do 12 k=1,k1 stm(i,j,k)=rbf(l) 12 l=l+1 ierr=nfmpi_close(ncid) end subroutine ! ---------------------------------------------------------------------- subroutine readnc(fn,vn,fld,l0) parameter(nbg0=nb0*ngy0,nbg1=nbg0-1,i01=i0+1,ibir=i2t/ngy0,j01=j0+1) character fn*(*),vn*(*),filename*10 dimension fld(i0,j0,l0),rbf(i2*j2*l0),nd(3) write(filename,'(a4,a2,a3)'),'data/',fn,'.nc' ierr=nfmpi_open(m_cart,filename,nf_nowrite,mpi_info_null,ncid) if (ierr .ne. 0) print*,fn,nfmpi_strerror(ierr) ierr=nfmpi_inq_varid(ncid,vn,itmp) if (ierr .ne. 0) print*,'nfmpi_inq_var ',fn,nfmpi_strerror(ierr) nc_kji(1)=l0 ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_kji,nc_kji,rbf) if (ierr .ne. 0) print*,'nfmpi_get_vara',fn,nfmpi_strerror(ierr) ierr=nfmpi_close(ncid) if (ierr .ne. 0) print*,fn,nfmpi_strerror(ierr) l=1 do 11 i=2,i1 do 11 j=2,j1 do 11 k=1,l0 fld(i,j,k)=rbf(l) 11 l=l+1 end subroutine ! ---------------------------------------------------------------------- subroutine timeavg(fd,fld,kl,ct) real*8 fld,fd,ct dimension fld(i0,j0,k1),fd(i0,j0,kl) do 100 k=1,kl do 100 j=2,j1 do 100 i=2,i1 100 fld(i,j,k)=fld(i,j,k)+ct*fd(i,j,k) end subroutine ! ---------------------------------------------------------------------- subroutine timeavg_2d(fd,fld,ct) real*8 fd,fld,ct dimension fld(i2,j2,1),fd(i2,j2,1) do 100 j=1,j2 do 100 i=1,i2 100 fld(i,j,1)=fld(i,j,1)+ct*fd(i,j,1) end subroutine ! ---------------------------------------------------------------------- subroutine mtx2rvec(fd,rbf,in0,jn0,nx,ny,nl,ip,jp) dimension fd(in0,jn0,nl),rbf(nx*ny*nl) l=1 ibegin=1+ip iend=nx+ibegin-1 jb=1+jp je=ny+jb-1 do 11 i=ibegin,iend do 11 j=jb,je do 11 k=1,nl rbf(l)=fd(i,j,k) 11 l=l+1 end subroutine ! ---------------------------------------------------------------------- subroutine mtx2rvec2(fd,rbf,in0,jn0,nx,ny,nl,ip,jp) real*8 fd,rbf dimension fd(in0,jn0,nl),rbf(nx*ny*nl) l=1 ibegin=1+ip iend=nx+ibegin-1 jb=1+jp je=ny+jb-1 do 11 k=1,nl do 11 j=jb,je do 11 i=ibegin,iend rbf(l)=fd(i,j,k) 11 l=l+1 end subroutine ! ---------------------------------------------------------------------- subroutine mtx2rvec_m(fd,rbf,in0,jn0,kn1,nx,ny,nk,nl,ip,jp) dimension fd(in0,jn0,kn1,nl),rbf(nx*ny*nk*nl) l=1 ibegin=1+ip iend=nx+ibegin-1 jb=1+jp je=ny+jb-1 do 12 m=1,nl do 12 k=1,nk do 12 j=jb,je do 12 i=ibegin,iend rbf(l)=fd(i,j,k,m) 12 l=l+1 end subroutine ! ---------------------------------------------------------------------- subroutine mtx2ivec(fd,rbf,in0,jn0,nx,ny,nl,ip,jp) integer*2 fd integer rbf dimension fd(in0,jn0,nl),rbf(nx*ny*nl) l=1 ibegin=1+ip iend=nx+ibegin-1 jb=1+jp je=ny+jb-1 do 11 k=1,nl do 11 j=jb,je do 11 i=ibegin,iend rbf(l)=int(fd(i,j,k)) 11 l=l+1 end subroutine ! ---------------------------------------------------------------------- subroutine mtx2dvec(fd,dbf) parameter(i2j2=i2*j2) real*8 fd,dbf dimension fd(i0,j0),dbf(i2j2) l=1 do 11 i=2,i1 do 11 j=2,j1 dbf(l)=fd(i,j) 11 l=l+1 end subroutine ! ---------------------------------------------------------------------- subroutine rvec2mtx(fd,rbf,in0,jn0,nx,ny,nl,ip,jp) dimension fd(in0,jn0,nl),rbf(nx*ny*nl) ibegin=1+ip iend=nx+ibegin-1 jb=1+jp je=ny+jb-1 l=1 do 11 i=ibegin,iend do 11 j=jb,je do 11 k=1,nl fd(i,j,k)=rbf(l) 11 l=l+1 end subroutine ! ---------------------------------------------------------------------- subroutine rvec2mtx2(fd,rbf,in0,jn0,nx,ny,nl,ip,jp) dimension fd(nx,ny,nl),rbf(nx*ny*nl) ibegin=1+ip iend=nx+ibegin-1 jb=1+jp je=ny+jb-1 l=1 do 11 i=ibegin,iend do 11 j=jb,je do 11 k=1,nl fd(i-1,j-1,k)=rbf(l) 11 l=l+1 end subroutine ! ---------------------------------------------------------------------- subroutine mtx2vec_c(fd,in,rbf) parameter(i2j2k1=i2*j2*k1) integer*2 in,nbf real*8 fd,rbf dimension fd(i0,j0,k1) dimension in(i0,j0,k1),rbf(i2j2k1) ! rm=rmin+1.e-5*rf ! rn=9999./rf l=1 do 11 k=1,k1 do 11 j=2,j1 do 11 i=2,i1 ! fd(i,j,k)=max(min(fd(i,j,k),rmin+rf),rmin) ! nbf(l)=-999*(1-in(i,j,k))+in(i,j,k)*rn*(fd(i,j,k)-rm) rbf(l)=fd(i,j,k)*in(i,j,k) ! nbf(l)=in(i,j,k)*rn*(fd(i,j,k)-rmin) 11 l=l+1 end subroutine ! ---------------------------------------------------------------------- subroutine mtx2vec_f(fd,iw,rbfw) parameter(i2j2k0=i2*j2*k0) integer*2 iw real*8 fd,rbfw dimension fd(i0,j0,k0) dimension iw(i0,j0,k0),rbfw(i2j2k0) ! rm=rmin+1.e-5*rf ! rn=9999./rf l=1 do 11 k=1,k0 do 11 j=2,j1 do 11 i=2,i1 ! fd(i,j,k)=max(min(fd(i,j,k),rmin+rf),rmin) ! nbf(l)=-999*(1-in(i,j,k))+in(i,j,k)*rn*(fd(i,j,k)-rm) rbfw(l)=fd(i,j,k)*iw(i,j,k) ! nbf(l)=in(i,j,k)*rn*(fd(i,j,k)-rmin) 11 l=l+1 end subroutine ! ---------------------------------------------------------------------- subroutine mtx2dec_c(fd,in,rbf) parameter(i2j2k1=i2*j2*k1) integer*2 in,nbf real*8 fd dimension fd(i0,j0,k1) dimension in(i0,j0,k1) real*8 rbf(i2j2k1) l=1 do 11 k=1,k1 do 11 j=2,j1 do 11 i=2,i1 rbf(l)=in(i,j,k)*fd(i,j,k) 11 l=l+1 end subroutine ! ---------------------------------------------------------------------- subroutine dvec2mtx(fd,dbf) parameter(i2j2=i2*j2) real*8 fd,dbf dimension fd(i0,j0),dbf(i2j2) l=1 do 11 i=2,i1 do 11 j=2,j1 fd(i,j)=dbf(l) 11 l=l+1 end subroutine ! ---------------------------------------------------------------------- subroutine pnetcdferrck(ierr) if(ierr.ne.nf_noerr)write(*,'(/2a)')'pnetcdf error: ',nfmpi_strerror(ierr) end subroutine subroutine restart if (mod(itf,nopt*itfday).eq.0.or.itf.eq.mxit)then if (myid.eq.0) print*,'write rerun file' if (lbred .eq. 1) call rescbred if (lbred .eq. 0) call write_rerun endif ! nopt: years of sving rerun files if(mod(itf,ncopt*360*itfday).eq.0) then ifl_sys=1 nys=itf/(360*itfday) if(myid.eq.0) then write(sys1,'(a11,i3.3,a13,i3.3)'),'test -e opt',nys,' || mkdir opt',nys write(sys2,'(a19,i3.3)'),'cp ./data/*.n! ./opt',nys call system(sys1) call system(sys2) print*,'saving rerun files in opt',nys ifl_sys=0 endif call mpi_bcast(ifl_sys,1,mpi_integer,0,m_cart,ierr) endif if (itf .ge. mxit) then call mpi_finalize(ierr) stop endif write(14,405) n360,nyr 405 format('save at day',i4,', year',i3) end subroutine subroutine finalize_io end subroutine subroutine rdnc_evp use comm, only: m_cart,myid,mylon,mylat use const, only: i2,j2,ngy0,ngx0 implicit none character :: fn*19 integer :: ncid,ierr,itmp integer(kind=mpi_offset_kind) :: ns_ij(2),nc_ij(2) fn = 'prepglo/data/evp.nc' ierr=nfmpi_open(m_cart,fn,nf_nowrite,mpi_info_null,ncid) ns_ij(1) = mylon*i2+1 ns_ij(2) = mylat*j2+1 nc_ij(1) = i2 nc_ij(2) = j2 ierr=nfmpi_inq_varid(ncid,'al',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_ij,nc_ij,al) ierr=nfmpi_inq_varid(ncid,'ar',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_ij,nc_ij,ar) ierr=nfmpi_inq_varid(ncid,'ab',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_ij,nc_ij,ab) ierr=nfmpi_inq_varid(ncid,'ac',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_ij,nc_ij,ac) ierr=nfmpi_inq_varid(ncid,'cl',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_ij,nc_ij,cl) ierr=nfmpi_inq_varid(ncid,'cb',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_ij,nc_ij,cb) ierr=nfmpi_inq_varid(ncid,'cc',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_ij,nc_ij,cc) ierr=nfmpi_inq_varid(ncid,'cr',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_ij,nc_ij,cr) ierr=nfmpi_inq_varid(ncid,'ct',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_ij,nc_ij,ct) ns_ij(1) = mylon*i2+1 ns_ij(2) = mylat*(j2+1)+1 nc_ij(1) = i2 nc_ij(2) = j2+1 ierr=nfmpi_inq_varid(ncid,'at',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_ij,nc_ij,at) ierr=nfmpi_close(ncid) end subroutine rdnc_evp subroutine rdnc_windmix use comm, only: m_cart use const, only: k2 implicit none character :: fn*23 integer :: ncid,ierr,itmp integer(kind=mpi_offset_kind) :: ns_i,nc_i fn = 'prepglo/data/windmix.nc' ierr=nfmpi_open(m_cart,fn,nf_nowrite,mpi_info_null,ncid) ns_i = 1 nc_i = k2 ierr=nfmpi_inq_varid(ncid,'vbk',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,vbk) ierr=nfmpi_inq_varid(ncid,'hbk',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,hbk) ierr=nfmpi_close(ncid) end subroutine rdnc_windmix subroutine rdnc_winds use comm, only: m_cart,mylon,mylat use const, only: i2,j2,ngx0,ngy0 implicit none character :: fn*21 integer :: ncid,ierr,itmp integer(kind=mpi_offset_kind) :: ns_ijt(3),nc_ijt(3) fn = 'prepglo/data/winds.nc' ierr=nfmpi_open(m_cart,fn,nf_nowrite,mpi_info_null,ncid) ns_ijt(1) = mylon*i2+1 ns_ijt(2) = mylat*j2+1 ns_ijt(3) = 1 nc_ijt(1) = i2 nc_ijt(2) = j2 nc_ijt(3) = 12 ! if (lscowf) then ierr=nfmpi_inq_varid(ncid,'tauxs',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_ijt,nc_ijt,taux) ierr=nfmpi_inq_varid(ncid,'tauys',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_ijt,nc_ijt,tauy) ! else ! ierr=nfmpi_inq_varid(ncid,'taux_data',itmp) ! ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_ijt,nc_ijt,taux) ! ierr=nfmpi_inq_varid(ncid,'tauy_data',itmp) ! ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_ijt,nc_ijt,tauy) ! endif ierr=nfmpi_close(ncid) end subroutine rdnc_winds subroutine rdnc_levitus(nm) use comm, only: m_cart,mylon,mylat use const, only: i0,j0,ngx0,ngy0,k1 implicit none character :: fn*28 integer :: ncid,ierr,itmp integer(kind=mpi_offset_kind) :: ns_ijkt(4),nc_ijkt(4) integer,intent(in) :: nm fn = 'prepglo/data/annualevitus.nc' ierr=nfmpi_open(m_cart,fn,nf_nowrite,mpi_info_null,ncid) ns_ijkt(1) = mylon*i0+1 ns_ijkt(2) = mylat*j0+1 ns_ijkt(3) = 1 ns_ijkt(4) = nm nc_ijkt(1) = i0 nc_ijkt(2) = j0 nc_ijkt(3) = k1 nc_ijkt(4) = 1 ierr=nfmpi_inq_varid(ncid,'s1_data',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_ijkt,nc_ijkt,sclim) ierr=nfmpi_inq_varid(ncid,'t1_data',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_ijkt,nc_ijkt,tclim) ierr=nfmpi_close(ncid) end subroutine rdnc_levitus subroutine rdnc_zkb use comm, only: m_cart,mylon,mylat use const, only: i0,j0,ngx0,ngy0,k1,k0,i01 implicit none character :: fn*19 integer :: ncid,ierr,itmp integer(kind=mpi_offset_kind) :: ns_i,nc_i,ns_ij(2),nc_ij(2) integer(kind=mpi_offset_kind) :: ns_ijk(3),nc_ijk(3) fn = 'prepglo/data/zkb.nc' ierr=nfmpi_open(m_cart,fn,nf_nowrite,mpi_info_null,ncid) ns_i = 1 nc_i = 1 ierr=nfmpi_inq_varid(ncid,'tlz',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,tlz) ns_i = 1 nc_i = k0+k1 ierr=nfmpi_inq_varid(ncid,'z',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,z) ns_i = 1 nc_i = k1 ierr=nfmpi_inq_varid(ncid,'odz',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,odz) ns_i = 1 nc_i = k0 ierr=nfmpi_inq_varid(ncid,'odzw',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,odzw) ns_ij(1) = mylon*i0+1 ns_ij(2) = mylat*j0+1 nc_ij(1) = i0 nc_ij(2) = j0 ierr=nfmpi_inq_varid(ncid,'kb',itmp) ierr=nfmpi_get_vara_int2_all(ncid,itmp,ns_ij,nc_ij,kb) ns_ij(1) = mylon*i0+1 ns_ij(2) = mylat*(j0+1)+1 nc_ij(1) = i0 nc_ij(2) = j0+1 ierr=nfmpi_inq_varid(ncid,'iv0',itmp) ierr=nfmpi_get_vara_int2_all(ncid,itmp,ns_ij,nc_ij,iv0) ns_ij(1) = mylon*(i01+1)+1 ns_ij(2) = mylat*j0+1 nc_ij(1) = i01+1 nc_ij(2) = j0 ierr=nfmpi_inq_varid(ncid,'iu0',itmp) ierr=nfmpi_get_vara_int2_all(ncid,itmp,ns_ij,nc_ij,iu0) ns_ijk(1) = mylon*i0+1 ns_ijk(2) = mylat*j0+1 ns_ijk(3) = 1 nc_ijk(1) = i0 nc_ijk(2) = j0 nc_ijk(3) = k0 ierr=nfmpi_inq_varid(ncid,'iw',itmp) ierr=nfmpi_get_vara_int2_all(ncid,itmp,ns_ijk,nc_ijk,iw) nc_ijk(3) = k1 ierr=nfmpi_inq_varid(ncid,'in',itmp) ierr=nfmpi_get_vara_int2_all(ncid,itmp,ns_ijk,nc_ijk,in) ns_ijk(2) = mylat*(j0+1)+1 nc_ijk(2) = j0+1 ierr=nfmpi_inq_varid(ncid,'iv',itmp) ierr=nfmpi_get_vara_int2_all(ncid,itmp,ns_ijk,nc_ijk,iv) ns_ijk(1) = mylon*(i01+1)+1 ns_ijk(2) = mylat*j0+1 nc_ijk(1) = i01+1 nc_ijk(2) = j0 ierr=nfmpi_inq_varid(ncid,'iu',itmp) ierr=nfmpi_get_vara_int2_all(ncid,itmp,ns_ijk,nc_ijk,iu) ierr=nfmpi_close(ncid) end subroutine rdnc_zkb subroutine rdnc_zkb2 use comm, only: m_cart,mylon,mylat use const, only: i0,j0 implicit none character :: fn*19 integer :: ncid,ierr,itmp integer(kind=mpi_offset_kind) :: ns_ij(2),nc_ij(2) fn = 'prepglo/data/zkb.nc' ierr=nfmpi_open(m_cart,fn,nf_nowrite,mpi_info_null,ncid) ns_ij(1) = mylon*i0+1 ns_ij(2) = mylat*j0+1 nc_ij(1) = i0 nc_ij(2) = j0 ierr=nfmpi_inq_varid(ncid,'rmets',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_ij,nc_ij,scr(:,:,1)) ierr=nfmpi_close(ncid) end subroutine rdnc_zkb2 subroutine rdnc_rundata use comm, only: m_cart,mylon,mylat use const, only: i0,j0,j1,j2,ngx0,ngy0 implicit none character :: fn*23 integer :: ncid,ierr,itmp integer(kind=mpi_offset_kind) :: ns_i,nc_i fn = 'prepglo/data/rundata.nc' ierr=nfmpi_open(m_cart,fn,nf_nowrite,mpi_info_null,ncid) ns_i = 1 nc_i = 5 ierr=nfmpi_inq_varid(ncid,'case',itmp) ierr=nfmpi_get_vara_text_all(ncid,itmp,ns_i,nc_i,case) nc_i = 63 ierr=nfmpi_inq_varid(ncid,'describ',itmp) ierr=nfmpi_get_vara_text_all(ncid,itmp,ns_i,nc_i,dscrib) nc_i = 1 ierr=nfmpi_inq_varid(ncid,'dt',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,dt) ierr=nfmpi_inq_varid(ncid,'tlz',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,tlz) ierr=nfmpi_inq_varid(ncid,'b',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,b) ierr=nfmpi_inq_varid(ncid,'g',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,g) ierr=nfmpi_inq_varid(ncid,'dm0',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,dm0) ierr=nfmpi_inq_varid(ncid,'de0',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,de0) ierr=nfmpi_inq_varid(ncid,'dmz0',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,dmz0) ierr=nfmpi_inq_varid(ncid,'rzmx',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,rzmx) ierr=nfmpi_inq_varid(ncid,'drag',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,drag) ierr=nfmpi_inq_varid(ncid,'fltw',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,fltw) ierr=nfmpi_inq_varid(ncid,'daodt',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,daodt) ierr=nfmpi_inq_varid(ncid,'odt',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,odt) ierr=nfmpi_inq_varid(ncid,'prn',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,prn) ierr=nfmpi_inq_varid(ncid,'orzmx',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,orzmx) ierr=nfmpi_inq_varid(ncid,'ofltw',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,ofltw) ierr=nfmpi_inq_varid(ncid,'rawf',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,rawf) ierr=nfmpi_inq_varid(ncid,'ktrm',itmp) ierr=nfmpi_get_vara_int_all(ncid,itmp,ns_i,nc_i,ktrm) ierr=nfmpi_inq_varid(ncid,'lrstrt',itmp) ierr=nfmpi_get_vara_int_all(ncid,itmp,ns_i,nc_i,lrstrt) ierr=nfmpi_inq_varid(ncid,'mxit',itmp) ierr=nfmpi_get_vara_int_all(ncid,itmp,ns_i,nc_i,mxit) ierr=nfmpi_inq_varid(ncid,'isav',itmp) ierr=nfmpi_get_vara_int_all(ncid,itmp,ns_i,nc_i,isav) ierr=nfmpi_inq_varid(ncid,'mxsav',itmp) ierr=nfmpi_get_vara_int_all(ncid,itmp,ns_i,nc_i,mxsav) ierr=nfmpi_inq_varid(ncid,'lopen',itmp) ierr=nfmpi_get_vara_int_all(ncid,itmp,ns_i,nc_i,lopen) ierr=nfmpi_inq_varid(ncid,'lmovi',itmp) ierr=nfmpi_get_vara_int_all(ncid,itmp,ns_i,nc_i,lmovi) ierr=nfmpi_inq_varid(ncid,'mvi',itmp) ierr=nfmpi_get_vara_int_all(ncid,itmp,ns_i,nc_i,mvi) ierr=nfmpi_inq_varid(ncid,'lfsrf',itmp) ierr=nfmpi_get_vara_int_all(ncid,itmp,ns_i,nc_i,lfsrf) ierr=nfmpi_inq_varid(ncid,'lsolver',itmp) ierr=nfmpi_get_vara_int_all(ncid,itmp,ns_i,nc_i,lsolver) ierr=nfmpi_inq_varid(ncid,'lprecon',itmp) ierr=nfmpi_get_vara_int_all(ncid,itmp,ns_i,nc_i,lprecon) ns_i = mylat*j2+1 nc_i = j2 ierr=nfmpi_inq_varid(ncid,'f',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,f) ierr=nfmpi_inq_varid(ncid,'tanphi',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,tanphi) ns_i = mylat*j1+1 nc_i = j1 ierr=nfmpi_inq_varid(ncid,'csv',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,csv) ierr=nfmpi_inq_varid(ncid,'ocsv',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,ocsv) ierr=nfmpi_inq_varid(ncid,'dxv',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,dxv) ierr=nfmpi_inq_varid(ncid,'odxv',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,odxv) ierr=nfmpi_inq_varid(ncid,'dyv',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,dyv) ierr=nfmpi_inq_varid(ncid,'odyv',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,odyv) ns_i = mylat*j0+1 nc_i = j0 ierr=nfmpi_inq_varid(ncid,'y',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,y) ierr=nfmpi_inq_varid(ncid,'ydeg',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,ydeg) ierr=nfmpi_inq_varid(ncid,'yv',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,yv) ierr=nfmpi_inq_varid(ncid,'yvdeg',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,yvdeg) ierr=nfmpi_inq_varid(ncid,'cs',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,cs) ierr=nfmpi_inq_varid(ncid,'ocs',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,ocs) ierr=nfmpi_inq_varid(ncid,'dx',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,dx) ierr=nfmpi_inq_varid(ncid,'odx',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,odx) ierr=nfmpi_inq_varid(ncid,'dy',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,dy) ierr=nfmpi_inq_varid(ncid,'ody',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,ody) ns_i = mylon*i0+1 nc_i = i0 ierr=nfmpi_inq_varid(ncid,'xdeg',itmp) ierr=nfmpi_get_vara_double_all(ncid,itmp,ns_i,nc_i,xdeg) ierr=nfmpi_close(ncid) end subroutine rdnc_rundata subroutine read_tide(fn,tide_flux) use comm, only : mylat,mylon use const, only: i0,j0,ngx0,ngy0 implicit none ! input character*(*), intent(in) :: fn real*8, dimension(i0,j0), intent(inout) :: tide_flux ! local variable integer :: ierr, tide_id, ncid integer(kind=mpi_offset_kind) :: ns_ij(2),nc_ij(2) ierr=nfmpi_open(m_cart,fn,nf_nowrite,mpi_info_null,ncid) ns_ij(1) = mylon*i0+1 ns_ij(2) = mylat*j0+1 nc_ij(1) = i0 nc_ij(2) = j0 ierr=nfmpi_inq_varid(ncid,"wave_dissipation",tide_id) call pnetcdferrck(ierr) ierr=nfmpi_get_vara_double_all(ncid,tide_id,ns_ij,nc_ij,tide_flux) call pnetcdferrck(ierr) ierr=nfmpi_close(ncid) end subroutine read_tide ! ---------------------------------------------------------------------- subroutine setrd(a,n,r) ! ---------------------------------------------------------------------- DIMENSION a(*) REAL*8 a,r integer :: i,n do i=1,n a(i)=r end do end subroutine setrd ! ---------------------------------------------------------------------- end module