ROMS
Loading...
Searching...
No Matches
Functions/Subroutines
set_3dfldr_mod Module Reference

Functions/Subroutines

subroutine set_3dfldr_tile (ng, tile, model, ifield, lbi, ubi, lbj, ubj, lbk, ubk, finp, fout, update, setbc)
 

Function/Subroutine Documentation

◆ set_3dfldr_tile()

subroutine set_3dfldr_mod::set_3dfldr_tile ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) model,
integer, intent(in) ifield,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) lbk,
integer, intent(in) ubk,
real(r8), dimension(lbi:,lbj:,lbk:,:), intent(in) finp,
real(r8), dimension(lbi:,lbj:,lbk:), intent(out) fout,
logical, intent(out) update,
logical, intent(in), optional setbc )

Definition at line 22 of file set_3dfldr.F.

26!***********************************************************************
27!
28 USE mod_param
29 USE mod_parallel
30 USE mod_iounits
31 USE mod_ncparam
32 USE mod_scalars
33!
34 USE exchange_3d_mod
35# ifdef DISTRIBUTE
36 USE mp_exchange_mod, ONLY : mp_exchange3d
37# endif
38 USE dateclock_mod, ONLY : time_string
39!
40! Imported variable declarations.
41!
42 logical, intent(in), optional :: SetBC
43
44 logical, intent(out) :: update
45
46 integer, intent(in) :: ng, tile, model, ifield
47 integer, intent(in) :: LBi, UBi, LBj, UBj, LBk, UBk
48!
49# ifdef ASSUMED_SHAPE
50 real(r8), intent(in) :: Finp(LBi:,LBj:,LBk:,:)
51 real(r8), intent(out) :: Fout(LBi:,LBj:,LBk:)
52# else
53 real(r8), intent(in) :: Finp(LBi:UBi,LBj:UBj,LBk:UBk,2)
54 real(r8), intent(out) :: Fout(LBi:UBi,LBj:UBj,LBk:UBk)
55# endif
56!
57! Local variable declarations.
58!
59 logical :: LapplyBC, Lgrided, Lonerec
60!
61 integer :: Tindex, gtype, i, it1, it2, j, k
62!
63 real(dp) :: SecScale, fac, fac1, fac2
64 real(r8) :: Fval
65!
66 character (len=22) :: DateString1, DateString2
67
68# include "set_bounds.h"
69!
70!--------------------------------------------------------------------
71! Set-up requested field for current tile.
72!--------------------------------------------------------------------
73!
74! Set switch to apply boundary conditions.
75!
76 IF (PRESENT(setbc)) THEN
77 lapplybc=setbc
78 ELSE
79 lapplybc=.true.
80 END IF
81!
82! Get requested field information from global storage.
83!
84 lgrided=linfo(1,ifield,ng)
85 lonerec=linfo(3,ifield,ng)
86 gtype =iinfo(1,ifield,ng)
87 tindex =iinfo(8,ifield,ng)
88 update=.true.
89!
90! Set linear, time interpolation factors. Fractional seconds are
91! rounded to the nearest milliseconds integer towards zero in the
92! time interpolation weights.
93!
94 secscale=1000.0_dp ! seconds to milliseconds
95 it1=3-tindex
96 it2=tindex
97 fac1=anint((time(ng)-tintrp(it2,ifield,ng))*secscale,r8)
98 fac2=anint((tintrp(it1,ifield,ng)-time(ng))*secscale,r8)
99!! CALL time_string (Tintrp(it1,ifield,ng), DateString1)
100!! CALL time_string (Tintrp(it2,ifield,ng), DateString2)
101!
102! Load time-invariant data. Time interpolation is not necessary.
103!
104 IF (lonerec) THEN
105 IF (lgrided) THEN
106 DO k=lbk,ubk
107 DO j=jstrr,jendr
108 DO i=istrr,iendr
109 fout(i,j,k)=finp(i,j,k,tindex)
110 END DO
111 END DO
112 END DO
113 ELSE
114 fval=fpoint(tindex,ifield,ng)
115 DO k=lbk,ubk
116 DO j=jstrr,jendr
117 DO i=istrr,iendr
118 fout(i,j,k)=fval
119 END DO
120 END DO
121 END DO
122 END IF
123!
124! Time-interpolate from gridded or point data.
125!
126 ELSE IF (((fac1*fac2).ge.0.0_dp).and. &
127 & ((fac1+fac2).gt.0.0_dp)) THEN
128 fac=1.0_dp/(fac1+fac2)
129 fac1=fac*fac1 ! nondimensional
130 fac2=fac*fac2 ! nondimensional
131 IF (lgrided) THEN
132 DO k=lbk,ubk
133 DO j=jstrr,jendr
134 DO i=istrr,iendr
135 fout(i,j,k)=fac1*finp(i,j,k,it1)+fac2*finp(i,j,k,it2)
136 END DO
137 END DO
138 END DO
139 ELSE
140 fval=fac1*fpoint(it1,ifield,ng)+fac2*fpoint(it2,ifield,ng)
141 DO k=lbk,ubk
142 DO j=jstrr,jendr
143 DO i=istrr,iendr
144 fout(i,j,k)=fval
145 END DO
146 END DO
147 END DO
148 END IF
149!
150! Activate synchronization flag if a new time record needs to be
151! read in at the next time step.
152!
153 IF ((time(ng)-dt(ng)).lt.tintrp(it2,ifield,ng)) THEN
154 IF (domain(ng)%SouthWest_Test(tile)) synchro_flag(ng)=.true.
155 END IF
156!
157! Unable to set-up requested field. Activate error flag to quit.
158!
159 ELSE
160 IF (domain(ng)%SouthWest_Test(tile)) THEN
161 IF (master) THEN
162 WRITE (stdout,10) trim(vname(1,ifield)), tdays(ng), &
163 & finfo(1,ifield,ng), finfo(2,ifield,ng), &
164 & finfo(3,ifield,ng), finfo(4,ifield,ng), &
165 & tintrp(it1,ifield,ng)*sec2day, &
166 & tintrp(it2,ifield,ng)*sec2day, &
167 & fac1*sec2day/secscale, &
168 & fac2*sec2day/secscale
169 END IF
170 10 FORMAT (/,' SET_3DFLDR - current model time', &
171 & ' exceeds ending value for variable: ',a, &
172 & /,14x,'TDAYS = ',f15.4, &
173 & /,14x,'Data Tmin = ',f15.4,2x,'Data Tmax = ',f15.4, &
174 & /,14x,'Data Tstr = ',f15.4,2x,'Data Tend = ',f15.4, &
175 & /,14x,'TINTRP1 = ',f15.4,2x,'TINTRP2 = ',f15.4, &
176 & /,14x,'FAC1 = ',f15.4,2x,'FAC2 = ',f15.4)
177 exit_flag=2
178 update=.false.
179 END IF
180 END IF
181!
182! Exchange boundary data.
183!
184 IF (update) THEN
185 IF (lapplybc.and.(ewperiodic(ng).or.nsperiodic(ng))) THEN
186 IF (gtype.eq.r3dvar) THEN
187 CALL exchange_r3d_tile (ng, tile, &
188 & lbi, ubi, lbj, ubj, lbk, ubk, &
189 & fout)
190 ELSE IF (gtype.eq.u3dvar) THEN
191 CALL exchange_u3d_tile (ng, tile, &
192 & lbi, ubi, lbj, ubj, lbk, ubk, &
193 & fout)
194 ELSE IF (gtype.eq.v3dvar) THEN
195 CALL exchange_v3d_tile (ng, tile, &
196 & lbi, ubi, lbj, ubj, lbk, ubk, &
197 & fout)
198 ELSE IF (gtype.eq.w3dvar) THEN
199 CALL exchange_w3d_tile (ng, tile, &
200 & lbi, ubi, lbj, ubj, lbk, ubk, &
201 & fout)
202 END IF
203 END IF
204
205# ifdef DISTRIBUTE
206 IF (.not.lapplybc) THEN
207 CALL mp_exchange3d (ng, tile, model, 1, &
208 & lbi, ubi, lbj, ubj, lbk, ubk, &
209 & nghostpoints, &
210 & .false., .false., &
211 & fout)
212 ELSE
213 CALL mp_exchange3d (ng, tile, model, 1, &
214 & lbi, ubi, lbj, ubj, lbk, ubk, &
215 & nghostpoints, &
216 & ewperiodic(ng), nsperiodic(ng), &
217 & fout)
218 END IF
219# endif
220 END IF
221
222 RETURN
dateclock_mod
Definition dateclock.F:2
dateclock_mod::time_string
subroutine, public time_string(mytime, date_string)
Definition dateclock.F:1272
exchange_3d_mod
Definition exchange_3d.F:2
exchange_3d_mod::exchange_u3d_tile
subroutine exchange_u3d_tile(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, a)
Definition exchange_3d.F:495
exchange_3d_mod::exchange_r3d_tile
subroutine exchange_r3d_tile(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, a)
Definition exchange_3d.F:283
exchange_3d_mod::exchange_v3d_tile
subroutine exchange_v3d_tile(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, a)
Definition exchange_3d.F:707
exchange_3d_mod::exchange_w3d_tile
subroutine exchange_w3d_tile(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, a)
Definition exchange_3d.F:920
mod_iounits
Definition mod_iounits.F:2
mod_iounits::stdout
integer stdout
Definition mod_iounits.F:195
mod_ncparam
Definition mod_ncparam.F:2
mod_ncparam::linfo
logical, dimension(:,:,:), allocatable linfo
Definition mod_ncparam.F:574
mod_ncparam::tintrp
real(dp), dimension(:,:,:), allocatable tintrp
Definition mod_ncparam.F:583
mod_ncparam::fpoint
real(dp), dimension(:,:,:), allocatable fpoint
Definition mod_ncparam.F:581
mod_ncparam::finfo
real(dp), dimension(:,:,:), allocatable finfo
Definition mod_ncparam.F:580
mod_ncparam::vname
character(len=maxlen), dimension(6, 0:nv) vname
Definition mod_ncparam.F:591
mod_ncparam::iinfo
integer, dimension(:,:,:), allocatable iinfo
Definition mod_ncparam.F:578
mod_parallel
Definition mod_parallel.F:2
mod_parallel::master
logical master
Definition mod_parallel.F:40
mod_param
Definition mod_param.F:2
mod_param::r3dvar
integer, parameter r3dvar
Definition mod_param.F:721
mod_param::nghostpoints
integer nghostpoints
Definition mod_param.F:710
mod_param::u3dvar
integer, parameter u3dvar
Definition mod_param.F:722
mod_param::domain
type(t_domain), dimension(:), allocatable domain
Definition mod_param.F:329
mod_param::w3dvar
integer, parameter w3dvar
Definition mod_param.F:724
mod_param::v3dvar
integer, parameter v3dvar
Definition mod_param.F:723
mod_scalars
Definition mod_scalars.F:2
mod_scalars::dt
real(dp), dimension(:), allocatable dt
Definition mod_scalars.F:269
mod_scalars::ewperiodic
logical, dimension(:), allocatable ewperiodic
Definition mod_scalars.F:510
mod_scalars::nsperiodic
logical, dimension(:), allocatable nsperiodic
Definition mod_scalars.F:511
mod_scalars::synchro_flag
logical, dimension(:), allocatable synchro_flag
Definition mod_scalars.F:1177
mod_scalars::tdays
real(dp), dimension(:), allocatable tdays
Definition mod_scalars.F:261
mod_scalars::sec2day
real(dp), parameter sec2day
Definition mod_scalars.F:817
mod_scalars::exit_flag
integer exit_flag
Definition mod_scalars.F:559
mod_scalars::time
real(dp), dimension(:), allocatable time
Definition mod_scalars.F:262
mp_exchange_mod
Definition mp_exchange.F:2
mp_exchange_mod::mp_exchange3d
subroutine mp_exchange3d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, lbk, ubk, nghost, ew_periodic, ns_periodic, a, b, c, d)
Definition mp_exchange.F:2037

References mod_param::domain, mod_scalars::dt, mod_scalars::ewperiodic, exchange_3d_mod::exchange_r3d_tile(), exchange_3d_mod::exchange_u3d_tile(), exchange_3d_mod::exchange_v3d_tile(), exchange_3d_mod::exchange_w3d_tile(), mod_scalars::exit_flag, mod_ncparam::finfo, mod_ncparam::fpoint, mod_ncparam::iinfo, mod_ncparam::linfo, mod_parallel::master, mp_exchange_mod::mp_exchange3d(), mod_param::nghostpoints, mod_scalars::nsperiodic, mod_param::r3dvar, mod_scalars::sec2day, mod_iounits::stdout, mod_scalars::synchro_flag, mod_scalars::tdays, mod_scalars::time, dateclock_mod::time_string(), mod_ncparam::tintrp, mod_param::u3dvar, mod_param::v3dvar, mod_ncparam::vname, and mod_param::w3dvar.

Referenced by ad_set_data_tile().

Here is the call graph for this function:
Here is the caller graph for this function: