subroutine setdata (is, ie, js, je) !----------------------------------------------------------------------- ! set up for data routine !----------------------------------------------------------------------- implicit none ! this is set up only for periodic monthly data. ! before adding a surface boundary condition ! 1. check numsbc and ntdbc are large enough (in csbc.h & ctdbc.h) ! 2. add index definition to UVic_ESCM (eq. itaux) ! 3. add code below and to atmos.F integer i, ie, is, id, im, iou, j, je, js, k, m, n real c10, c100, p001, p035, realdays include "size.h" include "param.h" include "pconst.h" include "stdunits.h" include "csbc.h" # if defined O_embm include "atm.h" # endif include "calendar.h" include "ctdbc.h" include "tmngr.h" include "switch.h" c10 = 10. c100 = 100. p001 = 0.001 p035 = 0.035 obc(:,:,:,:) = 0. do n=1,ntdbc ntdrec(n) = 12 period(n) = .true. do m=1, ntdrec(n) k = m + 1 aprec(m,n) = daypm(m) if (.not. eqyear .and. nint(aprec(m,n)) .eq. 28) then aprec(m,n) = aprec(m,n) + 0.2425 print*, '=>Warning: adding 0.2425 days to feb for leap year' endif ! create time stamp for the end of each month if (k .gt. 12) then call mkstmp (dstamp(m,n), 2, 1, 1, 0, 0, 0) else call mkstmp (dstamp(m,n), 1, k, 1, 0, 0, 0) endif enddo call timeinterpi (ntdrec(n), dstamp(1,n), aprec(1,n), tdrec(1,n) &, isbcstart(n), period(n)) call addtime (initial, imodeltime, itemptime) call subtime (itemptime, isbcstart(n), itemptime) daysbc(n) = realdays(itemptime) iprevm(n) = 1 inextm(n) = 2 method = 3 call timeinterp (daysbc(n), n, tdrec(1,n), aprec(1,n), ntdrec(n) &, period(n), method, inextd(n), iprevd(n), wprev(n) &, rdtdbc(n), inextm(n), iprevm(n)) enddo euler2 = .false. ! load previous and next data for all boundary conditions # if defined O_sbc_in_memory ! this is set up only for monthly data. do k=1,12 # else do k=1,2 # endif n = 1 do m=1,numsbc if (n .le. ntdbc) then rdtdbc(n) = .true. # if defined O_sbc_in_memory id = k im = k # else id = iprevd(n) im = iprevm(n) if (k .eq. 2) then id = inextd(n) im = inextm(n) endif # endif if ( m .eq. itaux ) then if (k .eq. 1) print*, 'x component of windstress' call get_sbc (n, 'O_tau.nc', 'O_tauX', id, im, c10, c0) elseif ( m .eq. itauy ) then if (k .eq. 1) print*, 'y component of windstress' call get_sbc (n, 'O_tau.nc', 'O_tauY', id, im, c10, c0) elseif ( m .eq. iws ) then if (k .eq. 1) print*, 'surface wind speed' call get_sbc (n, 'A_windsur.nc', 'A_windspd', id, im &, c100, c0) elseif ( m .eq. iaca ) then if (k .eq. 1) print*, 'atmospheric coalbedo' call get_sbc (n, 'A_calbatm.nc', 'A_calbatm', id, im &, c1, c0) # if defined O_npzd_iron elseif ( m .eq. idfeadep ) then if (k .eq. 1) print*, 'atmospheric iron deposition' call get_sbc (n, 'O_feflux.nc', 'O_feflux', id, im &, c1, c0) # endif # if defined O_read_my_stf if (k .eq. 1) print*, 'heat flux' elseif ( m .eq. ihflx ) then call get_sbc (n, 'F_heat.nc', 'F_heat', id, im, c1, c0) elseif ( m .eq. isflx ) then if (k .eq. 1) print*, 'salt flux' call get_sbc (n, 'F_salt.nc', 'F_salt', id, im, c1, c0) # elif defined O_replacst elseif ( m .eq. isst ) then if (k .eq. 1) print*, 'sea surface temperature' call get_sbc (n, 'O_tempsur.nc', 'O_tempsur', id, im &, c1, c0) elseif ( m .eq. isss ) then if (k .eq. 1) print*, 'sea surface salinity' call get_sbc (n, 'O_salsur.nc', 'O_salsur', id, im &, p001, -p035) # elif defined O_restorst elseif ( m .eq. ihflx ) then if (k .eq. 1) print*, 'data for restoring sst' call get_sbc (n, 'O_tempsur.nc', 'O_tempsur', id, im &, c1, c0) elseif ( m .eq. isflx ) then if (k .eq. 1) print*, 'data for restoring sss' call get_sbc (n, 'O_salsur.nc', 'O_salsur', id, im &, p001, -p035) # endif # if defined O_embm_awind && defined O_embm elseif ( m .eq. iwa ) then if (k .eq. 1) print*, 'surface wind angle' call get_sbc (n, 'A_windsur.nc', 'A_windang', id, im &, c1, c0) # endif # if defined O_embm elseif ( m .eq. iwxq ) then if (k .eq. 1) print*, 'x component of advecting wind' call get_sbc (n, 'A_wind.nc', 'A_windqX', id, im &, c100, c0) elseif ( m .eq. iwyq ) then if (k .eq. 1) print*, 'y component of advecting wind' call get_sbc (n, 'A_wind.nc', 'A_windqY', id, im &, c100, c0) elseif ( m .eq. iwxt ) then if (k .eq. 1) print*, 'x component of advecting wind' call get_sbc (n, 'A_wind.nc', 'A_windtX', id, im &, c100, c0) elseif ( m .eq. iwyt ) then if (k .eq. 1) print*, 'y component of advecting wind' call get_sbc (n, 'A_wind.nc', 'A_windtY', id, im &, c100, c0) # if defined O_carbon_co2_2d elseif ( m .eq. iwxc ) then if (k .eq. 1) print*, 'x component of advecting wind' call get_sbc (n, 'A_wind.nc', 'A_windcX', id, im &, c100, c0) elseif ( m .eq. iwyc ) then if (k .eq. 1) print*, 'y component of advecting wind' call get_sbc (n, 'A_wind.nc', 'A_windcY', id, im &, c100, c0) # endif # endif # if defined O_shortwave elseif ( m .eq. ipsw ) then if (k .eq. 1) print*, 'penetrating shortwave radiation' call get_sbc (n, 'O_penswr.nc', 'O_penswr', id, im &, c1, c0) # endif # if defined O_mtlm elseif ( m .eq. idtr ) then if (k .eq. 1) print*, 'diurnal temperature range' call get_sbc (n, 'L_diurtemp.nc', 'L_diurtemp', id, im &, c1, c0) # endif endif endif enddo enddo return end subroutine get_sbc (n, file, name, id, im, scalar, offset) implicit none character (*) :: file, name character(120) :: fname, new_file_name, text integer id, im, iou, n, ib(10), ic(10) logical exists real offset, scalar, C2K include "size.h" include "param.h" include "pconst.h" include "stdunits.h" include "csbc.h" include "ctdbc.h" logical inqvardef real tmpij(imtm2,jmtm2) C2K = 273.15 fname = new_file_name (file) inquire (file=trim(fname), exist=exists) if (.not. exists) then print*, "Error => ", trim(fname), " does not exist." stop 'get_sbc in setatm.f' else ib(:) = 1 ib(3) = id ic(:) = imtm2 ic(2) = jmtm2 ic(3) = 1 call openfile (fname, iou) if (inqvardef(name, iou)) then call getvara (name, iou, imtm2*jmtm2, ib, ic, tmpij &, scalar, offset) obc(2:imtm1,2:jmtm1,n,im) = tmpij(1:imtm2,1:jmtm2) call embmbc (obc(:,:,n,im)) text = "C" call getatttext (iou, name, 'units', text) if (name .ne. "L_diurtemp".and. trim(text) .eq. "K") & obc(:,:,n,im) = obc(:,:,n,im) - C2K where (obc(:,:,n,im) .gt. 1.e30) obc(:,:,n,im) = 0. endif endif n = n + 1 return end