New URL for NEMO forge! http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

fldread2.F90 in branches/UKMO/dev_3841_sbc/NEMOGCM/NEMO/OPA_SRC/SBC – NEMO

Context Navigation

source: branches/UKMO/dev_3841_sbc/NEMOGCM/NEMO/OPA_SRC/SBC/fldread2.F90 @ 4827

Last change on this file since 4827 was 4827, checked in by charris, 9 years ago
Some demonstration code changes.
File size: 68.9 KB

Line
1	MODULE fldread2
2	!!======================================================================
3	!! * MODULE fldread *
4	!! Ocean forcing: read input field for surface boundary condition
5	!!=====================================================================
6	!! History : 2.0 ! 06-2006 (S. Masson, G. Madec) Original code
7	!! ! 05-2008 (S. Alderson) Modified for Interpolation in memory
8	!! ! from input grid to model grid
9	!!----------------------------------------------------------------------
10
11	!!----------------------------------------------------------------------
12	!! fld_read : read input fields used for the computation of the
13	!! surface boundary condition
14	!!----------------------------------------------------------------------
15	USE oce ! ocean dynamics and tracers
16	USE dom_oce ! ocean space and time domain
17	USE phycst ! ???
18	USE in_out_manager ! I/O manager
19	USE iom ! I/O manager library
20	USE geo2ocean ! for vector rotation on to model grid
21	USE lib_mpp ! MPP library
22	USE wrk_nemo ! work arrays
23	USE ioipsl, ONLY : ymds2ju, ju2ymds ! for calendar
24	USE fld_def
25
26	IMPLICIT NONE
27	PRIVATE
28
29	PUBLIC fld_map2 ! routine called by tides_init
30	PUBLIC fld_read2, fld_fill2, fld_rot2 ! called by sbc... modules
31
32	TYPE, PUBLIC :: MAP_POINTER !: Array of integer pointers to 1D arrays
33	INTEGER, POINTER :: ptr(:)
34	END TYPE MAP_POINTER
35
36	!$AGRIF_DO_NOT_TREAT
37
38	!! keep list of all weights variables so they're only read in once
39	!! need to add AGRIF directives not to process this structure
40	!! also need to force wgtname to include AGRIF nest number
41	TYPE :: WGT !: Input weights related variables
42	CHARACTER(len = 256) :: wgtname ! current name of the NetCDF weight file
43	INTEGER , DIMENSION(2) :: ddims ! shape of input grid
44	INTEGER , DIMENSION(2) :: botleft ! top left corner of box in input grid containing
45	! ! current processor grid
46	INTEGER , DIMENSION(2) :: topright ! top right corner of box
47	INTEGER :: jpiwgt ! width of box on input grid
48	INTEGER :: jpjwgt ! height of box on input grid
49	INTEGER :: numwgt ! number of weights (4=bilinear, 16=bicubic)
50	INTEGER :: nestid ! for agrif, keep track of nest we're in
51	INTEGER :: overlap ! =0 when cyclic grid has no overlapping EW columns
52	! ! =>1 when they have one or more overlapping columns
53	! ! =-1 not cyclic
54	LOGICAL :: cyclic ! east-west cyclic or not
55	INTEGER, DIMENSION(:,:,:), POINTER :: data_jpi ! array of source integers
56	INTEGER, DIMENSION(:,:,:), POINTER :: data_jpj ! array of source integers
57	REAL(wp), DIMENSION(:,:,:), POINTER :: data_wgt ! array of weights on model grid
58	REAL(wp), DIMENSION(:,:,:), POINTER :: fly_dta ! array of values on input grid
59	REAL(wp), DIMENSION(:,:,:), POINTER :: col ! temporary array for reading in columns
60	END TYPE WGT
61
62	INTEGER, PARAMETER :: tot_wgts = 10
63	TYPE( WGT ), DIMENSION(tot_wgts) :: ref_wgts ! array of wgts
64	INTEGER :: nxt_wgt = 1 ! point to next available space in ref_wgts array
65
66	!$AGRIF_END_DO_NOT_TREAT
67
68	!!----------------------------------------------------------------------
69	!! NEMO/OPA 3.3 , NEMO Consortium (2010)
70	!! $Id: fldread.F90 3851 2013-03-27 10:03:54Z smasson $
71	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
72	!!----------------------------------------------------------------------
73	CONTAINS
74
75	SUBROUTINE fld_read2( kt, kn_fsbc, sd, map, kit, kt_offset )
76	!!---------------------------------------------------------------------
77	!! * ROUTINE fld_read *
78	!!
79	!! ** Purpose : provide at each time step the surface ocean fluxes
80	!! (momentum, heat, freshwater and runoff)
81	!!
82	!! ** Method : READ each input fields in NetCDF files using IOM
83	!! and intepolate it to the model time-step.
84	!! Several assumptions are made on the input file:
85	!! blahblahblah....
86	!!----------------------------------------------------------------------
87	INTEGER , INTENT(in ) :: kt ! ocean time step
88	INTEGER , INTENT(in ) :: kn_fsbc ! sbc computation period (in time step)
89	TYPE(FLD), INTENT(inout), DIMENSION(:) :: sd ! input field related variables
90	TYPE(MAP_POINTER),INTENT(in), OPTIONAL, DIMENSION(:) :: map ! global-to-local mapping indices
91	INTEGER , INTENT(in ), OPTIONAL :: kit ! subcycle timestep for timesplitting option
92	INTEGER , INTENT(in ), OPTIONAL :: kt_offset ! provide fields at time other than "now"
93	! kt_offset = -1 => fields at "before" time level
94	! kt_offset = +1 => fields at "after" time level
95	! etc.
96	!!
97	INTEGER :: itmp ! temporary variable
98	INTEGER :: imf ! size of the structure sd
99	INTEGER :: jf ! dummy indices
100	INTEGER :: isecend ! number of second since Jan. 1st 00h of nit000 year at nitend
101	INTEGER :: isecsbc ! number of seconds between Jan. 1st 00h of nit000 year and the middle of sbc time step
102	INTEGER :: it_offset ! local time offset variable
103	LOGICAL :: llnxtyr ! open next year file?
104	LOGICAL :: llnxtmth ! open next month file?
105	LOGICAL :: llstop ! stop is the file does not exist
106	LOGICAL :: ll_firstcall ! true if this is the first call to fld_read for this set of fields
107	REAL(wp) :: ztinta ! ratio applied to after records when doing time interpolation
108	REAL(wp) :: ztintb ! ratio applied to before records when doing time interpolation
109	CHARACTER(LEN=1000) :: clfmt ! write format
110	TYPE(MAP_POINTER) :: imap ! global-to-local mapping indices
111	!!---------------------------------------------------------------------
112	ll_firstcall = kt == nit000
113	IF( PRESENT(kit) ) ll_firstcall = ll_firstcall .and. kit == 1
114
115	it_offset = 0
116	IF( PRESENT(kt_offset) ) it_offset = kt_offset
117
118	imap%ptr => NULL()
119
120	! Note that shifting time to be centrered in the middle of sbc time step impacts only nsec_* variables of the calendar
121	IF( present(kit) ) THEN ! ignore kn_fsbc in this case
122	isecsbc = nsec_year + nsec1jan000 + (kit+it_offset)*NINT( rdt/REAL(nn_baro,wp) )
123	ELSE ! middle of sbc time step
124	isecsbc = nsec_year + nsec1jan000 + NINT(0.5 * REAL(kn_fsbc - 1,wp) * rdttra(1)) + it_offset * NINT(rdttra(1))
125	ENDIF
126	imf = SIZE( sd )
127	!
128	IF( ll_firstcall ) THEN ! initialization
129	DO jf = 1, imf
130	IF( PRESENT(map) ) imap = map(jf)
131	CALL fld_init( kn_fsbc, sd(jf), imap ) ! read each before field (put them in after as they will be swapped)
132	END DO
133	IF( lwp ) CALL wgt_print() ! control print
134	ENDIF
135	! ! ====================================== !
136	IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN ! update field at each kn_fsbc time-step !
137	! ! ====================================== !
138	!
139	DO jf = 1, imf ! --- loop over field --- !
140
141	IF( isecsbc > sd(jf)%nrec_a(2) .OR. ll_firstcall ) THEN ! read/update the after data?
142
143	IF( PRESENT(map) ) imap = map(jf) ! temporary definition of map
144
145	sd(jf)%nrec_b(:) = sd(jf)%nrec_a(:) ! swap before record informations
146	sd(jf)%rotn(1) = sd(jf)%rotn(2) ! swap before rotate informations
147	IF( sd(jf)%ln_tint ) sd(jf)%fdta(:,:,:,1) = sd(jf)%fdta(:,:,:,2) ! swap before record field
148
149	CALL fld_rec( kn_fsbc, sd(jf), kt_offset = it_offset, kit = kit ) ! update after record informations
150
151	! if kn_fsbc*rdttra is larger than nfreqh (which is kind of odd),
152	! it is possible that the before value is no more the good one... we have to re-read it
153	! if before is not the last record of the file currently opened and after is the first record to be read
154	! in a new file which means after = 1 (the file to be opened corresponds to the current time)
155	! or after = nreclast + 1 (the file to be opened corresponds to a future time step)
156	IF( .NOT. ll_firstcall .AND. sd(jf)%ln_tint .AND. sd(jf)%nrec_b(1) /= sd(jf)%nreclast &
157	& .AND. MOD( sd(jf)%nrec_a(1), sd(jf)%nreclast ) == 1 ) THEN
158	itmp = sd(jf)%nrec_a(1) ! temporary storage
159	sd(jf)%nrec_a(1) = sd(jf)%nreclast ! read the last record of the file currently opened
160	CALL fld_get( sd(jf), imap ) ! read after data
161	sd(jf)%fdta(:,:,:,1) = sd(jf)%fdta(:,:,:,2) ! re-swap before record field
162	sd(jf)%nrec_b(1) = sd(jf)%nrec_a(1) ! update before record informations
163	sd(jf)%nrec_b(2) = sd(jf)%nrec_a(2) - sd(jf)%nfreqh * 3600 ! assume freq to be in hours in this case
164	sd(jf)%rotn(1) = sd(jf)%rotn(2) ! update before rotate informations
165	sd(jf)%nrec_a(1) = itmp ! move back to after record
166	ENDIF
167
168	CALL fld_clopn( sd(jf) ) ! Do we need to open a new year/month/week/day file?
169
170	IF( sd(jf)%ln_tint ) THEN
171
172	! if kn_fsbc*rdttra is larger than nfreqh (which is kind of odd),
173	! it is possible that the before value is no more the good one... we have to re-read it
174	! if before record is not just just before the after record...
175	IF( .NOT. ll_firstcall .AND. MOD( sd(jf)%nrec_a(1), sd(jf)%nreclast ) /= 1 &
176	& .AND. sd(jf)%nrec_b(1) /= sd(jf)%nrec_a(1) - 1 ) THEN
177	sd(jf)%nrec_a(1) = sd(jf)%nrec_a(1) - 1 ! move back to before record
178	CALL fld_get( sd(jf), imap ) ! read after data
179	sd(jf)%fdta(:,:,:,1) = sd(jf)%fdta(:,:,:,2) ! re-swap before record field
180	sd(jf)%nrec_b(1) = sd(jf)%nrec_a(1) ! update before record informations
181	sd(jf)%nrec_b(2) = sd(jf)%nrec_a(2) - sd(jf)%nfreqh * 3600 ! assume freq to be in hours in this case
182	sd(jf)%rotn(1) = sd(jf)%rotn(2) ! update before rotate informations
183	sd(jf)%nrec_a(1) = sd(jf)%nrec_a(1) + 1 ! move back to after record
184	ENDIF
185
186	! do we have to change the year/month/week/day of the forcing field??
187	! if we do time interpolation we will need to open next year/month/week/day file before the end of the current
188	! one. If so, we are still before the end of the year/month/week/day when calling fld_rec so sd(jf)%nrec_a(1)
189	! will be larger than the record number that should be read for current year/month/week/day
190	! do we need next file data?
191	IF( sd(jf)%nrec_a(1) > sd(jf)%nreclast ) THEN
192
193	sd(jf)%nrec_a(1) = sd(jf)%nrec_a(1) - sd(jf)%nreclast !
194
195	IF( .NOT. ( sd(jf)%ln_clim .AND. sd(jf)%cltype == 'yearly' ) ) THEN ! close/open the current/new file
196
197	llnxtmth = sd(jf)%cltype == 'monthly' .OR. nday == nmonth_len(nmonth) ! open next month file?
198	llnxtyr = sd(jf)%cltype == 'yearly' .OR. (nmonth == 12 .AND. llnxtmth) ! open next year file?
199
200	! if the run finishes at the end of the current year/month/week/day, we will allow next
201	! year/month/week/day file to be not present. If the run continue further than the current
202	! year/month/week/day, next year/month/week/day file must exist
203	isecend = nsec_year + nsec1jan000 + (nitend - kt) * NINT(rdttra(1)) ! second at the end of the run
204	llstop = isecend > sd(jf)%nrec_a(2) ! read more than 1 record of next year
205	! we suppose that the date of next file is next day (should be ok even for weekly files...)
206	CALL fld_clopn( sd(jf), nyear + COUNT((/llnxtyr /)) , &
207	& nmonth + COUNT((/llnxtmth/)) - 12 * COUNT((/llnxtyr /)), &
208	& nday + 1 - nmonth_len(nmonth) * COUNT((/llnxtmth/)), llstop )
209
210	IF( sd(jf)%num <= 0 .AND. .NOT. llstop ) THEN ! next year file does not exist
211	CALL ctl_warn('next year/month/week/day file: '//TRIM(sd(jf)%clname)// &
212	& ' not present -> back to current year/month/day')
213	CALL fld_clopn( sd(jf) ) ! back to the current year/month/day
214	sd(jf)%nrec_a(1) = sd(jf)%nreclast ! force to read the last record in the current year file
215	ENDIF
216
217	ENDIF
218	ENDIF ! open need next file?
219
220	ENDIF ! temporal interpolation?
221
222	! read after data
223	CALL fld_get( sd(jf), imap )
224
225	ENDIF ! read new data?
226	END DO ! --- end loop over field --- !
227
228	! CALL fld_rot( kt, sd ) ! rotate vector before/now/after fields if needed
229
230	DO jf = 1, imf ! --- loop over field --- !
231	!
232	IF( sd(jf)%ln_tint ) THEN ! temporal interpolation
233	IF(lwp .AND. kt - nit000 <= 100 ) THEN
234	clfmt = "('fld_read: var ', a, ' kt = ', i8, ' (', f7.2,' days), Y/M/D = ', i4.4,'/', i2.2,'/', i2.2," // &
235	& "', records b/a: ', i4.4, '/', i4.4, ' (days ', f7.2,'/', f7.2, ')')"
236	WRITE(numout, clfmt) TRIM( sd(jf)%clvar ), kt, REAL(isecsbc,wp)/rday, nyear, nmonth, nday, &
237	& sd(jf)%nrec_b(1), sd(jf)%nrec_a(1), REAL(sd(jf)%nrec_b(2),wp)/rday, REAL(sd(jf)%nrec_a(2),wp)/rday
238	WRITE(numout, *) 'it_offset is : ',it_offset
239	ENDIF
240	! temporal interpolation weights
241	ztinta = REAL( isecsbc - sd(jf)%nrec_b(2), wp ) / REAL( sd(jf)%nrec_a(2) - sd(jf)%nrec_b(2), wp )
242	ztintb = 1. - ztinta
243	!CDIR COLLAPSE
244	sd(jf)%fnow(:,:,:) = ztintb * sd(jf)%fdta(:,:,:,1) + ztinta * sd(jf)%fdta(:,:,:,2)
245	ELSE ! nothing to do...
246	IF(lwp .AND. kt - nit000 <= 100 ) THEN
247	clfmt = "('fld_read: var ', a, ' kt = ', i8,' (', f7.2,' days), Y/M/D = ', i4.4,'/', i2.2,'/', i2.2," // &
248	& "', record: ', i4.4, ' (days ', f7.2, ' <-> ', f7.2, ')')"
249	WRITE(numout, clfmt) TRIM(sd(jf)%clvar), kt, REAL(isecsbc,wp)/rday, nyear, nmonth, nday, &
250	& sd(jf)%nrec_a(1), REAL(sd(jf)%nrec_b(2),wp)/rday, REAL(sd(jf)%nrec_a(2),wp)/rday
251	ENDIF
252	ENDIF
253	!
254	IF( kt == nitend - kn_fsbc + 1 ) CALL iom_close( sd(jf)%num ) ! Close the input files
255
256	END DO ! --- end loop over field --- !
257	!
258	! ! ====================================== !
259	ENDIF ! update field at each kn_fsbc time-step !
260	! ! ====================================== !
261	!
262	END SUBROUTINE fld_read2
263
264
265	SUBROUTINE fld_init( kn_fsbc, sdjf, map )
266	!!---------------------------------------------------------------------
267	!! * ROUTINE fld_init *
268	!!
269	!! ** Purpose : - if time interpolation, read before data
270	!! - open current year file
271	!!----------------------------------------------------------------------
272	INTEGER , INTENT(in ) :: kn_fsbc ! sbc computation period (in time step)
273	TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables
274	TYPE(MAP_POINTER),INTENT(in) :: map ! global-to-local mapping indices
275	!!
276	LOGICAL :: llprevyr ! are we reading previous year file?
277	LOGICAL :: llprevmth ! are we reading previous month file?
278	LOGICAL :: llprevweek ! are we reading previous week file?
279	LOGICAL :: llprevday ! are we reading previous day file?
280	LOGICAL :: llprev ! llprevyr .OR. llprevmth .OR. llprevweek .OR. llprevday
281	INTEGER :: idvar ! variable id
282	INTEGER :: inrec ! number of record existing for this variable
283	INTEGER :: iyear, imonth, iday ! first day of the current file in yyyy mm dd
284	INTEGER :: isec_week ! number of seconds since start of the weekly file
285	CHARACTER(LEN=1000) :: clfmt ! write format
286	!!---------------------------------------------------------------------
287	llprevyr = .FALSE.
288	llprevmth = .FALSE.
289	llprevweek = .FALSE.
290	llprevday = .FALSE.
291	isec_week = 0
292
293	! define record informations
294	CALL fld_rec( kn_fsbc, sdjf, ldbefore = .TRUE. ) ! return before values in sdjf%nrec_a (as we will swap it later)
295
296	! Note that shifting time to be centrered in the middle of sbc time step impacts only nsec_* variables of the calendar
297
298	IF( sdjf%ln_tint ) THEN ! we need to read the previous record and we will put it in the current record structure
299
300	IF( sdjf%nrec_a(1) == 0 ) THEN ! we redefine record sdjf%nrec_a(1) with the last record of previous year file
301	IF ( sdjf%nfreqh == -12 ) THEN ! yearly mean
302	IF( sdjf%cltype == 'yearly' ) THEN ! yearly file
303	sdjf%nrec_a(1) = 1 ! force to read the unique record
304	llprevyr = .NOT. sdjf%ln_clim ! use previous year file?
305	ELSE
306	CALL ctl_stop( "fld_init: yearly mean file must be in a yearly type of file: "//TRIM(sdjf%clrootname) )
307	ENDIF
308	ELSEIF( sdjf%nfreqh == -1 ) THEN ! monthly mean
309	IF( sdjf%cltype == 'monthly' ) THEN ! monthly file
310	sdjf%nrec_a(1) = 1 ! force to read the unique record
311	llprevmth = .TRUE. ! use previous month file?
312	llprevyr = llprevmth .AND. nmonth == 1 ! use previous year file?
313	ELSE ! yearly file
314	sdjf%nrec_a(1) = 12 ! force to read december mean
315	llprevyr = .NOT. sdjf%ln_clim ! use previous year file?
316	ENDIF
317	ELSE ! higher frequency mean (in hours)
318	IF ( sdjf%cltype == 'monthly' ) THEN ! monthly file
319	sdjf%nrec_a(1) = 24 * nmonth_len(nmonth-1) / sdjf%nfreqh ! last record of previous month
320	llprevmth = .TRUE. ! use previous month file?
321	llprevyr = llprevmth .AND. nmonth == 1 ! use previous year file?
322	ELSEIF( sdjf%cltype(1:4) == 'week' ) THEN ! weekly file
323	llprevweek = .TRUE. ! use previous week file?
324	sdjf%nrec_a(1) = 24 * 7 / sdjf%nfreqh ! last record of previous week
325	isec_week = NINT(rday) * 7 ! add a shift toward previous week
326	ELSEIF( sdjf%cltype == 'daily' ) THEN ! daily file
327	sdjf%nrec_a(1) = 24 / sdjf%nfreqh ! last record of previous day
328	llprevday = .TRUE. ! use previous day file?
329	llprevmth = llprevday .AND. nday == 1 ! use previous month file?
330	llprevyr = llprevmth .AND. nmonth == 1 ! use previous year file?
331	ELSE ! yearly file
332	sdjf%nrec_a(1) = 24 * nyear_len(0) / sdjf%nfreqh ! last record of previous year
333	llprevyr = .NOT. sdjf%ln_clim ! use previous year file?
334	ENDIF
335	ENDIF
336	ENDIF
337	!
338	IF ( sdjf%cltype(1:4) == 'week' ) THEN
339	isec_week = isec_week + ksec_week( sdjf%cltype(6:8) ) ! second since the beginning of the week
340	llprevmth = isec_week > nsec_month ! longer time since the beginning of the week than the month
341	llprevyr = llprevmth .AND. nmonth == 1
342	ENDIF
343	llprev = llprevyr .OR. llprevmth .OR. llprevweek .OR. llprevday
344	!
345	iyear = nyear - COUNT((/llprevyr /))
346	imonth = nmonth - COUNT((/llprevmth/)) + 12 * COUNT((/llprevyr /))
347	iday = nday - COUNT((/llprevday/)) + nmonth_len(nmonth-1) * COUNT((/llprevmth/)) - isec_week / NINT(rday)
348	!
349	CALL fld_clopn( sdjf, iyear, imonth, iday, .NOT. llprev )
350
351	! if previous year/month/day file does not exist, we switch to the current year/month/day
352	IF( llprev .AND. sdjf%num <= 0 ) THEN
353	CALL ctl_warn( 'previous year/month/week/day file: '//TRIM(sdjf%clrootname)// &
354	& ' not present -> back to current year/month/week/day' )
355	! we force to read the first record of the current year/month/day instead of last record of previous year/month/day
356	llprev = .FALSE.
357	sdjf%nrec_a(1) = 1
358	CALL fld_clopn( sdjf )
359	ENDIF
360
361	IF( llprev ) THEN ! check if the record sdjf%nrec_a(1) exists in the file
362	idvar = iom_varid( sdjf%num, sdjf%clvar ) ! id of the variable sdjf%clvar
363	IF( idvar <= 0 ) RETURN
364	inrec = iom_file( sdjf%num )%dimsz( iom_file( sdjf%num )%ndims(idvar), idvar ) ! size of the last dim of idvar
365	sdjf%nrec_a(1) = MIN( sdjf%nrec_a(1), inrec ) ! make sure we select an existing record
366	ENDIF
367
368	! read before data in after arrays(as we will swap it later)
369	CALL fld_get( sdjf, map )
370
371	clfmt = "('fld_init : time-interpolation for ', a, ' read previous record = ', i4, ' at time = ', f7.2, ' days')"
372	IF(lwp) WRITE(numout, clfmt) TRIM(sdjf%clvar), sdjf%nrec_a(1), REAL(sdjf%nrec_a(2),wp)/rday
373
374	ENDIF
375	!
376	END SUBROUTINE fld_init
377
378
379	SUBROUTINE fld_rec( kn_fsbc, sdjf, ldbefore, kit, kt_offset )
380	!!---------------------------------------------------------------------
381	!! * ROUTINE fld_rec *
382	!!
383	!! ** Purpose : Compute
384	!! if sdjf%ln_tint = .TRUE.
385	!! nrec_a: record number and its time (nrec_b is obtained from nrec_a when swapping)
386	!! if sdjf%ln_tint = .FALSE.
387	!! nrec_a(1): record number
388	!! nrec_b(2) and nrec_a(2): time of the beginning and end of the record (for print only)
389	!!----------------------------------------------------------------------
390	INTEGER , INTENT(in ) :: kn_fsbc ! sbc computation period (in time step)
391	TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables
392	LOGICAL , INTENT(in ), OPTIONAL :: ldbefore ! sent back before record values (default = .FALSE.)
393	INTEGER , INTENT(in ), OPTIONAL :: kit ! index of barotropic subcycle
394	! used only if sdjf%ln_tint = .TRUE.
395	INTEGER , INTENT(in ), OPTIONAL :: kt_offset ! Offset of required time level compared to "now"
396	! time level in units of time steps.
397	!!
398	LOGICAL :: llbefore ! local definition of ldbefore
399	INTEGER :: iendrec ! end of this record (in seconds)
400	INTEGER :: imth ! month number
401	INTEGER :: ifreq_sec ! frequency mean (in seconds)
402	INTEGER :: isec_week ! number of seconds since the start of the weekly file
403	INTEGER :: it_offset ! local time offset variable
404	REAL(wp) :: ztmp ! temporary variable
405	!!----------------------------------------------------------------------
406	!
407	! Note that shifting time to be centrered in the middle of sbc time step impacts only nsec_* variables of the calendar
408	!
409	IF( PRESENT(ldbefore) ) THEN ; llbefore = ldbefore .AND. sdjf%ln_tint ! needed only if sdjf%ln_tint = .TRUE.
410	ELSE ; llbefore = .FALSE.
411	ENDIF
412	!
413	it_offset = 0
414	IF( PRESENT(kt_offset) ) it_offset = kt_offset
415	IF( PRESENT(kit) ) THEN ; it_offset = ( kit + it_offset ) * NINT( rdt/REAL(nn_baro,wp) )
416	ELSE ; it_offset = it_offset * NINT( rdttra(1) )
417	ENDIF
418	!
419	! ! =========== !
420	IF ( sdjf%nfreqh == -12 ) THEN ! yearly mean
421	! ! =========== !
422	!
423	IF( sdjf%ln_tint ) THEN ! time interpolation, shift by 1/2 record
424	!
425	! INT( ztmp )
426	! /\|\
427	! 1 \| *----
428	! 0 \|----(
429	! \|----+----\|--> time
430	! 0 /\|\ 1 (nday/nyear_len(1))
431	! \|
432	! \|
433	! forcing record : 1
434	!
435	ztmp = REAL( nday, wp ) / REAL( nyear_len(1), wp ) + 0.5 + REAL( it_offset, wp )
436	sdjf%nrec_a(1) = 1 + INT( ztmp ) - COUNT((/llbefore/))
437	! swap at the middle of the year
438	IF( llbefore ) THEN ; sdjf%nrec_a(2) = nsec1jan000 - NINT(0.5 * rday) * nyear_len(0)
439	ELSE ; sdjf%nrec_a(2) = nsec1jan000 + NINT(0.5 * rday) * nyear_len(1)
440	ENDIF
441	ELSE ! no time interpolation
442	sdjf%nrec_a(1) = 1
443	sdjf%nrec_a(2) = NINT(rday) * nyear_len(1) + nsec1jan000 ! swap at the end of the year
444	sdjf%nrec_b(2) = nsec1jan000 ! beginning of the year (only for print)
445	ENDIF
446	!
447	! ! ============ !
448	ELSEIF( sdjf%nfreqh == -1 ) THEN ! monthly mean !
449	! ! ============ !
450	!
451	IF( sdjf%ln_tint ) THEN ! time interpolation, shift by 1/2 record
452	!
453	! INT( ztmp )
454	! /\|\
455	! 1 \| *----
456	! 0 \|----(
457	! \|----+----\|--> time
458	! 0 /\|\ 1 (nday/nmonth_len(nmonth))
459	! \|
460	! \|
461	! forcing record : nmonth
462	!
463	ztmp = REAL( nday, wp ) / REAL( nmonth_len(nmonth), wp ) + 0.5 + REAL( it_offset, wp )
464	imth = nmonth + INT( ztmp ) - COUNT((/llbefore/))
465	IF( sdjf%cltype == 'monthly' ) THEN ; sdjf%nrec_a(1) = 1 + INT( ztmp ) - COUNT((/llbefore/))
466	ELSE ; sdjf%nrec_a(1) = imth
467	ENDIF
468	sdjf%nrec_a(2) = nmonth_half( imth ) + nsec1jan000 ! swap at the middle of the month
469	ELSE ! no time interpolation
470	IF( sdjf%cltype == 'monthly' ) THEN ; sdjf%nrec_a(1) = 1
471	ELSE ; sdjf%nrec_a(1) = nmonth
472	ENDIF
473	sdjf%nrec_a(2) = nmonth_end(nmonth ) + nsec1jan000 ! swap at the end of the month
474	sdjf%nrec_b(2) = nmonth_end(nmonth-1) + nsec1jan000 ! beginning of the month (only for print)
475	ENDIF
476	!
477	! ! ================================ !
478	ELSE ! higher frequency mean (in hours)
479	! ! ================================ !
480	!
481	ifreq_sec = sdjf%nfreqh * 3600 ! frequency mean (in seconds)
482	IF( sdjf%cltype(1:4) == 'week' ) isec_week = ksec_week( sdjf%cltype(6:8) ) ! since the first day of the current week
483	! number of second since the beginning of the file
484	IF( sdjf%cltype == 'monthly' ) THEN ; ztmp = REAL(nsec_month,wp) ! since the first day of the current month
485	ELSEIF( sdjf%cltype(1:4) == 'week' ) THEN ; ztmp = REAL(isec_week ,wp) ! since the first day of the current week
486	ELSEIF( sdjf%cltype == 'daily' ) THEN ; ztmp = REAL(nsec_day ,wp) ! since 00h of the current day
487	ELSE ; ztmp = REAL(nsec_year ,wp) ! since 00h on Jan 1 of the current year
488	ENDIF
489	ztmp = ztmp + 0.5 * REAL(kn_fsbc - 1, wp) * rdttra(1) + REAL( it_offset, wp ) ! centrered in the middle of sbc time step
490	ztmp = ztmp + 0.01 * rdttra(1) ! avoid truncation error
491	IF( sdjf%ln_tint ) THEN ! time interpolation, shift by 1/2 record
492	!
493	! INT( ztmp/ifreq_sec + 0.5 )
494	! /\|\
495	! 2 \| *-----(
496	! 1 \| *-----(
497	! 0 \|--(
498	! \|--+--\|--+--\|--+--\|--> time
499	! 0 /\|\ 1 /\|\ 2 /\|\ 3 (ztmp/ifreq_sec)
500	! \| \| \|
501	! \| \| \|
502	! forcing record : 1 2 3
503	!
504	ztmp= ztmp / REAL(ifreq_sec, wp) + 0.5
505	ELSE ! no time interpolation
506	!
507	! INT( ztmp/ifreq_sec )
508	! /\|\
509	! 2 \| *-----(
510	! 1 \| *-----(
511	! 0 \|-----(
512	! \|--+--\|--+--\|--+--\|--> time
513	! 0 /\|\ 1 /\|\ 2 /\|\ 3 (ztmp/ifreq_sec)
514	! \| \| \|
515	! \| \| \|
516	! forcing record : 1 2 3
517	!
518	ztmp= ztmp / REAL(ifreq_sec, wp)
519	ENDIF
520	sdjf%nrec_a(1) = 1 + INT( ztmp ) - COUNT((/llbefore/)) ! record number to be read
521
522	iendrec = ifreq_sec * sdjf%nrec_a(1) + nsec1jan000 ! end of this record (in second)
523	! add the number of seconds between 00h Jan 1 and the end of previous month/week/day (ok if nmonth=1)
524	IF( sdjf%cltype == 'monthly' ) iendrec = iendrec + NINT(rday) * SUM(nmonth_len(1:nmonth -1))
525	IF( sdjf%cltype(1:4) == 'week' ) iendrec = iendrec + ( nsec_year - isec_week )
526	IF( sdjf%cltype == 'daily' ) iendrec = iendrec + NINT(rday) * ( nday_year - 1 )
527	IF( sdjf%ln_tint ) THEN
528	sdjf%nrec_a(2) = iendrec - ifreq_sec / 2 ! swap at the middle of the record
529	ELSE
530	sdjf%nrec_a(2) = iendrec ! swap at the end of the record
531	sdjf%nrec_b(2) = iendrec - ifreq_sec ! beginning of the record (only for print)
532	ENDIF
533	!
534	ENDIF
535	!
536	END SUBROUTINE fld_rec
537
538
539	SUBROUTINE fld_get( sdjf, map )
540	!!---------------------------------------------------------------------
541	!! * ROUTINE fld_get *
542	!!
543	!! ** Purpose : read the data
544	!!----------------------------------------------------------------------
545	TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables
546	TYPE(MAP_POINTER),INTENT(in) :: map ! global-to-local mapping indices
547	!!
548	INTEGER :: ipk ! number of vertical levels of sdjf%fdta ( 2D: ipk=1 ; 3D: ipk=jpk )
549	INTEGER :: iw ! index into wgts array
550	INTEGER :: ipdom ! index of the domain
551	!!---------------------------------------------------------------------
552	!
553	ipk = SIZE( sdjf%fnow, 3 )
554	!
555	IF( ASSOCIATED(map%ptr) ) THEN
556	IF( sdjf%ln_tint ) THEN ; CALL fld_map2( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1), map%ptr )
557	ELSE ; CALL fld_map2( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,: ), sdjf%nrec_a(1), map%ptr )
558	ENDIF
559	ELSE IF( LEN(TRIM(sdjf%wgtname)) > 0 ) THEN
560	CALL wgt_list( sdjf, iw )
561	IF( sdjf%ln_tint ) THEN ; CALL fld_interp( sdjf%num, sdjf%clvar, iw , ipk , sdjf%fdta(:,:,:,2), sdjf%nrec_a(1) )
562	ELSE ; CALL fld_interp( sdjf%num, sdjf%clvar, iw , ipk , sdjf%fnow(:,:,: ), sdjf%nrec_a(1) )
563	ENDIF
564	ELSE
565	IF( SIZE(sdjf%fnow, 1) == jpi ) THEN ; ipdom = jpdom_data
566	ELSE ; ipdom = jpdom_unknown
567	ENDIF
568	SELECT CASE( ipk )
569	CASE(1)
570	IF( sdjf%ln_tint ) THEN ; CALL iom_get( sdjf%num, ipdom, sdjf%clvar, sdjf%fdta(:,:,1,2), sdjf%nrec_a(1) )
571	ELSE ; CALL iom_get( sdjf%num, ipdom, sdjf%clvar, sdjf%fnow(:,:,1 ), sdjf%nrec_a(1) )
572	ENDIF
573	CASE DEFAULT
574	IF( sdjf%ln_tint ) THEN ; CALL iom_get( sdjf%num, ipdom, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1) )
575	ELSE ; CALL iom_get( sdjf%num, ipdom, sdjf%clvar, sdjf%fnow(:,:,: ), sdjf%nrec_a(1) )
576	ENDIF
577	END SELECT
578	ENDIF
579	!
580	sdjf%rotn(2) = .false. ! vector not yet rotated
581
582	END SUBROUTINE fld_get
583
584	SUBROUTINE fld_map2( num, clvar, dta, nrec, map )
585	!!---------------------------------------------------------------------
586	!! * ROUTINE fld_map *
587	!!
588	!! ** Purpose : read global data from file and map onto local data
589	!! using a general mapping (for open boundaries)
590	!!----------------------------------------------------------------------
591	#if defined key_bdy
592	USE bdy_oce, ONLY: dta_global, dta_global2 ! workspace to read in global data arrays
593	#endif
594	INTEGER , INTENT(in ) :: num ! stream number
595	CHARACTER(LEN=*) , INTENT(in ) :: clvar ! variable name
596	REAL(wp), DIMENSION(:,:,:), INTENT(out) :: dta ! output field on model grid (2 dimensional)
597	INTEGER , INTENT(in ) :: nrec ! record number to read (ie time slice)
598	INTEGER, DIMENSION(:) , INTENT(in ) :: map ! global-to-local mapping indices
599	!!
600	INTEGER :: ipi ! length of boundary data on local process
601	INTEGER :: ipj ! length of dummy dimension ( = 1 )
602	INTEGER :: ipk ! number of vertical levels of dta ( 2D: ipk=1 ; 3D: ipk=jpk )
603	INTEGER :: ilendta ! length of data in file
604	INTEGER :: idvar ! variable ID
605	INTEGER :: ib, ik, ji, jj ! loop counters
606	INTEGER :: ierr
607	REAL(wp), POINTER, DIMENSION(:,:,:) :: dta_read ! work space for global data
608	!!---------------------------------------------------------------------
609
610	ipi = SIZE( dta, 1 )
611	ipj = 1
612	ipk = SIZE( dta, 3 )
613
614	idvar = iom_varid( num, clvar )
615	ilendta = iom_file(num)%dimsz(1,idvar)
616
617	#if defined key_bdy
618	ipj = iom_file(num)%dimsz(2,idvar)
619	IF (ipj == 1) THEN ! we assume that this is a structured open boundary file
620	dta_read => dta_global
621	ELSE
622	dta_read => dta_global2
623	ENDIF
624	#endif
625
626	IF(lwp) WRITE(numout,*) 'Dim size for ',TRIM(clvar),' is ', ilendta
627	IF(lwp) WRITE(numout,*) 'Number of levels for ',TRIM(clvar),' is ', ipk
628
629	SELECT CASE( ipk )
630	CASE(1) ; CALL iom_get ( num, jpdom_unknown, clvar, dta_read(1:ilendta,1:ipj,1 ), nrec )
631	CASE DEFAULT ; CALL iom_get ( num, jpdom_unknown, clvar, dta_read(1:ilendta,1:ipj,1:ipk), nrec )
632	END SELECT
633	!
634	IF (ipj==1) THEN
635	DO ib = 1, ipi
636	DO ik = 1, ipk
637	dta(ib,1,ik) = dta_read(map(ib),1,ik)
638	END DO
639	END DO
640	ELSE ! we assume that this is a structured open boundary file
641	DO ib = 1, ipi
642	jj=1+floor(REAL(map(ib)-1)/REAL(ilendta))
643	ji=map(ib)-(jj-1)*ilendta
644	DO ik = 1, ipk
645	dta(ib,1,ik) = dta_read(ji,jj,ik)
646	END DO
647	END DO
648	ENDIF
649
650	END SUBROUTINE fld_map2
651
652
653	SUBROUTINE fld_rot2( kt, sd )
654	!!---------------------------------------------------------------------
655	!! * ROUTINE fld_rot *
656	!!
657	!! ** Purpose : Vector fields may need to be rotated onto the local grid direction
658	!!----------------------------------------------------------------------
659	INTEGER , INTENT(in ) :: kt ! ocean time step
660	TYPE(FLD), INTENT(inout), DIMENSION(:) :: sd ! input field related variables
661	!!
662	INTEGER :: ju,jv,jk,jn ! loop indices
663	INTEGER :: imf ! size of the structure sd
664	INTEGER :: ill ! character length
665	INTEGER :: iv ! indice of V component
666	REAL(wp), POINTER, DIMENSION(:,:) :: utmp, vtmp ! temporary arrays for vector rotation
667	CHARACTER (LEN=100) :: clcomp ! dummy weight name
668	!!---------------------------------------------------------------------
669
670	CALL wrk_alloc( jpi,jpj, utmp, vtmp )
671
672	!! (sga: following code should be modified so that pairs arent searched for each time
673	!
674	imf = SIZE( sd )
675	DO ju = 1, imf
676	ill = LEN_TRIM( sd(ju)%vcomp )
677	DO jn = 2-COUNT((/sd(ju)%ln_tint/)), 2
678	IF( ill > 0 .AND. .NOT. sd(ju)%rotn(jn) ) THEN ! find vector rotations required
679	IF( sd(ju)%vcomp(1:1) == 'U' ) THEN ! east-west component has symbolic name starting with 'U'
680	! look for the north-south component which has same symbolic name but with 'U' replaced with 'V'
681	clcomp = 'V' // sd(ju)%vcomp(2:ill) ! works even if ill == 1
682	iv = -1
683	DO jv = 1, imf
684	IF( TRIM(sd(jv)%vcomp) == TRIM(clcomp) ) iv = jv
685	END DO
686	IF( iv > 0 ) THEN ! fields ju and iv are two components which need to be rotated together
687	DO jk = 1, SIZE( sd(ju)%fnow, 3 )
688	IF( sd(ju)%ln_tint )THEN
689	CALL rot_rep( sd(ju)%fdta(:,:,jk,jn), sd(iv)%fdta(:,:,jk,jn), 'T', 'en->i', utmp(:,:) )
690	CALL rot_rep( sd(ju)%fdta(:,:,jk,jn), sd(iv)%fdta(:,:,jk,jn), 'T', 'en->j', vtmp(:,:) )
691	sd(ju)%fdta(:,:,jk,jn) = utmp(:,:) ; sd(iv)%fdta(:,:,jk,jn) = vtmp(:,:)
692	ELSE
693	CALL rot_rep( sd(ju)%fnow(:,:,jk ), sd(iv)%fnow(:,:,jk ), 'T', 'en->i', utmp(:,:) )
694	CALL rot_rep( sd(ju)%fnow(:,:,jk ), sd(iv)%fnow(:,:,jk ), 'T', 'en->j', vtmp(:,:) )
695	sd(ju)%fnow(:,:,jk ) = utmp(:,:) ; sd(iv)%fnow(:,:,jk ) = vtmp(:,:)
696	ENDIF
697	END DO
698	sd(ju)%rotn(jn) = .TRUE. ! vector was rotated
699	IF( lwp .AND. kt == nit000 ) WRITE(numout,*) &
700	& 'fld_read: vector pair ('//TRIM(sd(ju)%clvar)//', '//TRIM(sd(iv)%clvar)//') rotated on to model grid'
701	ENDIF
702	ENDIF
703	ENDIF
704	END DO
705	END DO
706	!
707	CALL wrk_dealloc( jpi,jpj, utmp, vtmp )
708	!
709	END SUBROUTINE fld_rot2
710
711
712	SUBROUTINE fld_clopn( sdjf, kyear, kmonth, kday, ldstop )
713	!!---------------------------------------------------------------------
714	!! * ROUTINE fld_clopn *
715	!!
716	!! ** Purpose : update the file name and open the file
717	!!----------------------------------------------------------------------
718	TYPE(FLD) , INTENT(inout) :: sdjf ! input field related variables
719	INTEGER, OPTIONAL, INTENT(in ) :: kyear ! year value
720	INTEGER, OPTIONAL, INTENT(in ) :: kmonth ! month value
721	INTEGER, OPTIONAL, INTENT(in ) :: kday ! day value
722	LOGICAL, OPTIONAL, INTENT(in ) :: ldstop ! stop if open to read a non-existing file (default = .TRUE.)
723	!!
724	LOGICAL :: llprevyr ! are we reading previous year file?
725	LOGICAL :: llprevmth ! are we reading previous month file?
726	INTEGER :: iyear, imonth, iday ! first day of the current file in yyyy mm dd
727	INTEGER :: isec_week ! number of seconds since start of the weekly file
728	INTEGER :: indexyr ! year undex (O/1/2: previous/current/next)
729	INTEGER :: iyear_len, imonth_len ! length (days) of iyear and imonth !
730	CHARACTER(len = 256):: clname ! temporary file name
731	!!----------------------------------------------------------------------
732	IF( PRESENT(kyear) ) THEN ! use given values
733	iyear = kyear
734	imonth = kmonth
735	iday = kday
736	ELSE ! use current day values
737	IF ( sdjf%cltype(1:4) == 'week' ) THEN ! find the day of the beginning of the week
738	isec_week = ksec_week( sdjf%cltype(6:8) ) ! second since the beginning of the week
739	llprevmth = isec_week > nsec_month ! longer time since beginning of the week than the month
740	llprevyr = llprevmth .AND. nmonth == 1
741	ELSE
742	isec_week = 0
743	llprevmth = .FALSE.
744	llprevyr = .FALSE.
745	ENDIF
746	iyear = nyear - COUNT((/llprevyr /))
747	imonth = nmonth - COUNT((/llprevmth/)) + 12 * COUNT((/llprevyr /))
748	iday = nday + nmonth_len(nmonth-1) * COUNT((/llprevmth/)) - isec_week / NINT(rday)
749	ENDIF
750
751	! build the new filename if not climatological data
752	clname=TRIM(sdjf%clrootname)
753	!
754	! note that sdjf%ln_clim is is only acting on the presence of the year in the file name
755	IF( .NOT. sdjf%ln_clim ) THEN
756	WRITE(clname, '(a,"_y",i4.4)' ) TRIM( sdjf%clrootname ), iyear ! add year
757	IF( sdjf%cltype /= 'yearly' ) WRITE(clname, '(a,"m" ,i2.2)' ) TRIM( clname ), imonth ! add month
758	ELSE
759	! build the new filename if climatological data
760	IF( sdjf%cltype /= 'yearly' ) WRITE(clname, '(a,"_m",i2.2)' ) TRIM( sdjf%clrootname ), imonth ! add month
761	ENDIF
762	IF( sdjf%cltype == 'daily' .OR. sdjf%cltype(1:4) == 'week' ) &
763	& WRITE(clname, '(a,"d" ,i2.2)' ) TRIM( clname ), iday ! add day
764	!
765	IF( TRIM(clname) /= TRIM(sdjf%clname) .OR. sdjf%num == 0 ) THEN ! new file to be open
766
767	sdjf%clname = TRIM(clname)
768	IF( sdjf%num /= 0 ) CALL iom_close( sdjf%num ) ! close file if already open
769	CALL iom_open( sdjf%clname, sdjf%num, ldstop = ldstop, ldiof = LEN(TRIM(sdjf%wgtname)) > 0 )
770
771	! find the last record to be read -> update sdjf%nreclast
772	indexyr = iyear - nyear + 1
773	iyear_len = nyear_len( indexyr )
774	SELECT CASE ( indexyr )
775	CASE ( 0 ) ; imonth_len = 31 ! previous year -> imonth = 12
776	CASE ( 1 ) ; imonth_len = nmonth_len(imonth)
777	CASE ( 2 ) ; imonth_len = 31 ! next year -> imonth = 1
778	END SELECT
779
780	! last record to be read in the current file
781	IF ( sdjf%nfreqh == -12 ) THEN ; sdjf%nreclast = 1 ! yearly mean
782	ELSEIF( sdjf%nfreqh == -1 ) THEN ! monthly mean
783	IF( sdjf%cltype == 'monthly' ) THEN ; sdjf%nreclast = 1
784	ELSE ; sdjf%nreclast = 12
785	ENDIF
786	ELSE ! higher frequency mean (in hours)
787	IF( sdjf%cltype == 'monthly' ) THEN ; sdjf%nreclast = 24 * imonth_len / sdjf%nfreqh
788	ELSEIF( sdjf%cltype(1:4) == 'week' ) THEN ; sdjf%nreclast = 24 * 7 / sdjf%nfreqh
789	ELSEIF( sdjf%cltype == 'daily' ) THEN ; sdjf%nreclast = 24 / sdjf%nfreqh
790	ELSE ; sdjf%nreclast = 24 * iyear_len / sdjf%nfreqh
791	ENDIF
792	ENDIF
793
794	ENDIF
795	!
796	END SUBROUTINE fld_clopn
797
798
799	SUBROUTINE fld_fill2( sdf, sdf_n, nct, cdir, cdcaller, cdtitle, cdnam )
800	!!---------------------------------------------------------------------
801	!! * ROUTINE fld_fill *
802	!!
803	!! ** Purpose : fill sdf with sdf_n and control print
804	!!----------------------------------------------------------------------
805	TYPE(FLD) , DIMENSION(:), INTENT(inout) :: sdf ! structure of input fields (file informations, fields read)
806	TYPE(FLD_N), DIMENSION(:), INTENT(in ) :: sdf_n ! array of namelist information structures
807	CHARACTER(len=*) , INTENT(in ) :: cdir ! Root directory for location of flx files
808	CHARACTER(len=*) , INTENT(in ) :: cdcaller !
809	CHARACTER(len=*) , INTENT(in ) :: cdtitle !
810	CHARACTER(len=*) , INTENT(in ) :: cdnam !
811	INTEGER , INTENT(in ) :: nct
812	!
813	INTEGER :: jf ! dummy indices
814	!!---------------------------------------------------------------------
815
816	DO jf = 1, SIZE(sdf)
817	sdf(jf)%clrootname = TRIM( cdir )//TRIM( sdf_n(jf)%clname )
818	IF( TRIM( sdf_n(jf)%clname ) == 'oasis' ) THEN
819	sdf(jf)%loasis=.TRUE.
820	sdf(jf)%lfile=.FALSE.
821	ELSE IF( TRIM( sdf_n(jf)%clname ) == 'file' ) THEN
822	sdf(jf)%loasis=.FALSE.
823	sdf(jf)%lfile=.TRUE.
824	END IF
825	sdf(jf)%clname = "not yet defined"
826	sdf(jf)%clvgrd = sdf_n(jf)%clvgrd
827	IF( TRIM( sdf_n(jf)%clcat ) == 'yes' ) THEN
828	sdf(jf)%nct=nct
829	ELSE
830	sdf(jf)%nct=1
831	END IF
832	sdf(jf)%nfreqh = sdf_n(jf)%nfreqh
833	sdf(jf)%nsgn = 1
834	sdf(jf)%clvar = sdf_n(jf)%clvar
835	sdf(jf)%ln_tint = sdf_n(jf)%ln_tint
836	sdf(jf)%ln_clim = sdf_n(jf)%ln_clim
837	sdf(jf)%cltype = sdf_n(jf)%cltype
838	sdf(jf)%num = -1
839	sdf(jf)%wgtname = " "
840	sdf(jf)%nid(:) = 0
841	sdf(jf)%ninfo = OASIS_idle
842
843	IF( LEN( TRIM(sdf_n(jf)%wname) ) > 0 ) sdf(jf)%wgtname = TRIM( cdir )//TRIM( sdf_n(jf)%wname )
844	sdf(jf)%vcomp = sdf_n(jf)%vcomp
845	sdf(jf)%rotn(:) = .TRUE. ! pretend to be rotated -> won't try to rotate data before the first call to fld_get
846	IF( sdf(jf)%cltype(1:4) == 'week' .AND. nn_leapy == 0 ) &
847	& CALL ctl_stop('fld_clopn: weekly file ('//TRIM(sdf(jf)%clrootname)//') needs nn_leapy = 1')
848	IF( sdf(jf)%cltype(1:4) == 'week' .AND. sdf(jf)%ln_clim ) &
849	& CALL ctl_stop('fld_clopn: weekly file ('//TRIM(sdf(jf)%clrootname)//') needs ln_clim = .FALSE.')
850	END DO
851
852	IF(lwp) THEN ! control print
853	WRITE(numout,*)
854	WRITE(numout,*) TRIM( cdcaller )//' : '//TRIM( cdtitle )
855	WRITE(numout,*) (/ ('~', jf = 1, LEN_TRIM( cdcaller ) ) /)
856	WRITE(numout,*) ' '//TRIM( cdnam )//' Namelist'
857	WRITE(numout,*) ' list of files and frequency (>0: in hours ; <0 in months)'
858	DO jf = 1, SIZE(sdf)
859	WRITE(numout,*) ' root filename: ' , TRIM( sdf(jf)%clrootname ), &
860	& ' variable name: ' , TRIM( sdf(jf)%clvar )
861	WRITE(numout,*) ' frequency: ' , sdf(jf)%nfreqh , &
862	& ' time interp: ' , sdf(jf)%ln_tint , &
863	& ' climatology: ' , sdf(jf)%ln_clim , &
864	& ' weights : ' , TRIM( sdf(jf)%wgtname ), &
865	& ' pairing : ' , TRIM( sdf(jf)%vcomp ), &
866	& ' data type: ' , sdf(jf)%cltype
867	call flush(numout)
868	END DO
869	ENDIF
870
871	END SUBROUTINE fld_fill2
872
873
874	SUBROUTINE wgt_list( sd, kwgt )
875	!!---------------------------------------------------------------------
876	!! * ROUTINE wgt_list *
877	!!
878	!! ** Purpose : search array of WGTs and find a weights file
879	!! entry, or return a new one adding it to the end
880	!! if it is a new entry, the weights data is read in and
881	!! restructured (fld_weight)
882	!!----------------------------------------------------------------------
883	TYPE( FLD ), INTENT(in ) :: sd ! field with name of weights file
884	INTEGER , INTENT(inout) :: kwgt ! index of weights
885	!!
886	INTEGER :: kw, nestid ! local integer
887	LOGICAL :: found ! local logical
888	!!----------------------------------------------------------------------
889	!
890	!! search down linked list
891	!! weights filename is either present or we hit the end of the list
892	found = .FALSE.
893
894	!! because agrif nest part of filenames are now added in iom_open
895	!! to distinguish between weights files on the different grids, need to track
896	!! nest number explicitly
897	nestid = 0
898	#if defined key_agrif
899	nestid = Agrif_Fixed()
900	#endif
901	DO kw = 1, nxt_wgt-1
902	IF( TRIM(ref_wgts(kw)%wgtname) == TRIM(sd%wgtname) .AND. &
903	ref_wgts(kw)%nestid == nestid) THEN
904	kwgt = kw
905	found = .TRUE.
906	EXIT
907	ENDIF
908	END DO
909	IF( .NOT.found ) THEN
910	kwgt = nxt_wgt
911	CALL fld_weight( sd )
912	ENDIF
913	!
914	END SUBROUTINE wgt_list
915
916
917	SUBROUTINE wgt_print( )
918	!!---------------------------------------------------------------------
919	!! * ROUTINE wgt_print *
920	!!
921	!! ** Purpose : print the list of known weights
922	!!----------------------------------------------------------------------
923	INTEGER :: kw !
924	!!----------------------------------------------------------------------
925	!
926	DO kw = 1, nxt_wgt-1
927	WRITE(numout,*) 'weight file: ',TRIM(ref_wgts(kw)%wgtname)
928	WRITE(numout,*) ' ddims: ',ref_wgts(kw)%ddims(1),ref_wgts(kw)%ddims(2)
929	WRITE(numout,*) ' numwgt: ',ref_wgts(kw)%numwgt
930	WRITE(numout,*) ' jpiwgt: ',ref_wgts(kw)%jpiwgt
931	WRITE(numout,*) ' jpjwgt: ',ref_wgts(kw)%jpjwgt
932	WRITE(numout,*) ' botleft: ',ref_wgts(kw)%botleft
933	WRITE(numout,*) ' topright: ',ref_wgts(kw)%topright
934	IF( ref_wgts(kw)%cyclic ) THEN
935	WRITE(numout,*) ' cyclical'
936	IF( ref_wgts(kw)%overlap > 0 ) WRITE(numout,*) ' with overlap of ', ref_wgts(kw)%overlap
937	ELSE
938	WRITE(numout,*) ' not cyclical'
939	ENDIF
940	IF( ASSOCIATED(ref_wgts(kw)%data_wgt) ) WRITE(numout,*) ' allocated'
941	END DO
942	!
943	END SUBROUTINE wgt_print
944
945
946	SUBROUTINE fld_weight( sd )
947	!!---------------------------------------------------------------------
948	!! * ROUTINE fld_weight *
949	!!
950	!! ** Purpose : create a new WGT structure and fill in data from
951	!! file, restructuring as required
952	!!----------------------------------------------------------------------
953	TYPE( FLD ), INTENT(in) :: sd ! field with name of weights file
954	!!
955	INTEGER :: jn ! dummy loop indices
956	INTEGER :: inum ! temporary logical unit
957	INTEGER :: id ! temporary variable id
958	INTEGER :: ipk ! temporary vertical dimension
959	CHARACTER (len=5) :: aname
960	INTEGER , DIMENSION(3) :: ddims
961	INTEGER , POINTER, DIMENSION(:,:) :: data_src
962	REAL(wp), POINTER, DIMENSION(:,:) :: data_tmp
963	LOGICAL :: cyclical
964	INTEGER :: zwrap ! local integer
965	!!----------------------------------------------------------------------
966	!
967	CALL wrk_alloc( jpi,jpj, data_src ) ! integer
968	CALL wrk_alloc( jpi,jpj, data_tmp )
969	!
970	IF( nxt_wgt > tot_wgts ) THEN
971	CALL ctl_stop("fld_weight: weights array size exceeded, increase tot_wgts")
972	ENDIF
973	!
974	!! new weights file entry, add in extra information
975	!! a weights file represents a 2D grid of a certain shape, so we assume that the current
976	!! input data file is representative of all other files to be opened and processed with the
977	!! current weights file
978
979	!! open input data file (non-model grid)
980	CALL iom_open( sd%clname, inum, ldiof = LEN(TRIM(sd%wgtname)) > 0 )
981
982	!! get dimensions
983	id = iom_varid( inum, sd%clvar, ddims )
984
985	!! close it
986	CALL iom_close( inum )
987
988	!! now open the weights file
989
990	CALL iom_open ( sd%wgtname, inum ) ! interpolation weights
991	IF ( inum > 0 ) THEN
992
993	!! determine whether we have an east-west cyclic grid
994	!! from global attribute called "ew_wrap" in the weights file
995	!! note that if not found, iom_getatt returns -999 and cyclic with no overlap is assumed
996	!! since this is the most common forcing configuration
997
998	CALL iom_getatt(inum, 'ew_wrap', zwrap)
999	IF( zwrap >= 0 ) THEN
1000	cyclical = .TRUE.
1001	ELSE IF( zwrap == -999 ) THEN
1002	cyclical = .TRUE.
1003	zwrap = 0
1004	ELSE
1005	cyclical = .FALSE.
1006	ENDIF
1007
1008	ref_wgts(nxt_wgt)%ddims(1) = ddims(1)
1009	ref_wgts(nxt_wgt)%ddims(2) = ddims(2)
1010	ref_wgts(nxt_wgt)%wgtname = sd%wgtname
1011	ref_wgts(nxt_wgt)%overlap = zwrap
1012	ref_wgts(nxt_wgt)%cyclic = cyclical
1013	ref_wgts(nxt_wgt)%nestid = 0
1014	#if defined key_agrif
1015	ref_wgts(nxt_wgt)%nestid = Agrif_Fixed()
1016	#endif
1017	!! weights file is stored as a set of weights (wgt01->wgt04 or wgt01->wgt16)
1018	!! for each weight wgtNN there is an integer array srcNN which gives the point in
1019	!! the input data grid which is to be multiplied by the weight
1020	!! they are both arrays on the model grid so the result of the multiplication is
1021	!! added into an output array on the model grid as a running sum
1022
1023	!! two possible cases: bilinear (4 weights) or bicubic (16 weights)
1024	id = iom_varid(inum, 'src05', ldstop=.FALSE.)
1025	IF( id <= 0) THEN
1026	ref_wgts(nxt_wgt)%numwgt = 4
1027	ELSE
1028	ref_wgts(nxt_wgt)%numwgt = 16
1029	ENDIF
1030
1031	ALLOCATE( ref_wgts(nxt_wgt)%data_jpi(jpi,jpj,4) )
1032	ALLOCATE( ref_wgts(nxt_wgt)%data_jpj(jpi,jpj,4) )
1033	ALLOCATE( ref_wgts(nxt_wgt)%data_wgt(jpi,jpj,ref_wgts(nxt_wgt)%numwgt) )
1034
1035	DO jn = 1,4
1036	aname = ' '
1037	WRITE(aname,'(a3,i2.2)') 'src',jn
1038	data_tmp(:,:) = 0
1039	CALL iom_get ( inum, jpdom_data, aname, data_tmp(:,:) )
1040	data_src(:,:) = INT(data_tmp(:,:))
1041	ref_wgts(nxt_wgt)%data_jpj(:,:,jn) = 1 + (data_src(:,:)-1) / ref_wgts(nxt_wgt)%ddims(1)
1042	ref_wgts(nxt_wgt)%data_jpi(:,:,jn) = data_src(:,:) - ref_wgts(nxt_wgt)%ddims(1)*(ref_wgts(nxt_wgt)%data_jpj(:,:,jn)-1)
1043	END DO
1044
1045	DO jn = 1, ref_wgts(nxt_wgt)%numwgt
1046	aname = ' '
1047	WRITE(aname,'(a3,i2.2)') 'wgt',jn
1048	ref_wgts(nxt_wgt)%data_wgt(:,:,jn) = 0.0
1049	CALL iom_get ( inum, jpdom_data, aname, ref_wgts(nxt_wgt)%data_wgt(:,:,jn) )
1050	END DO
1051	CALL iom_close (inum)
1052
1053	! find min and max indices in grid
1054	ref_wgts(nxt_wgt)%botleft(1) = MINVAL(ref_wgts(nxt_wgt)%data_jpi(:,:,:))
1055	ref_wgts(nxt_wgt)%botleft(2) = MINVAL(ref_wgts(nxt_wgt)%data_jpj(:,:,:))
1056	ref_wgts(nxt_wgt)%topright(1) = MAXVAL(ref_wgts(nxt_wgt)%data_jpi(:,:,:))
1057	ref_wgts(nxt_wgt)%topright(2) = MAXVAL(ref_wgts(nxt_wgt)%data_jpj(:,:,:))
1058
1059	! and therefore dimensions of the input box
1060	ref_wgts(nxt_wgt)%jpiwgt = ref_wgts(nxt_wgt)%topright(1) - ref_wgts(nxt_wgt)%botleft(1) + 1
1061	ref_wgts(nxt_wgt)%jpjwgt = ref_wgts(nxt_wgt)%topright(2) - ref_wgts(nxt_wgt)%botleft(2) + 1
1062
1063	! shift indexing of source grid
1064	ref_wgts(nxt_wgt)%data_jpi(:,:,:) = ref_wgts(nxt_wgt)%data_jpi(:,:,:) - ref_wgts(nxt_wgt)%botleft(1) + 1
1065	ref_wgts(nxt_wgt)%data_jpj(:,:,:) = ref_wgts(nxt_wgt)%data_jpj(:,:,:) - ref_wgts(nxt_wgt)%botleft(2) + 1
1066
1067	! create input grid, give it a halo to allow gradient calculations
1068	! SA: +3 stencil is a patch to avoid out-of-bound computation in some configuration.
1069	! a more robust solution will be given in next release
1070	ipk = SIZE(sd%fnow, 3)
1071	ALLOCATE( ref_wgts(nxt_wgt)%fly_dta(ref_wgts(nxt_wgt)%jpiwgt+3, ref_wgts(nxt_wgt)%jpjwgt+3 ,ipk) )
1072	IF( ref_wgts(nxt_wgt)%cyclic ) ALLOCATE( ref_wgts(nxt_wgt)%col(1,ref_wgts(nxt_wgt)%jpjwgt+3,ipk) )
1073
1074	nxt_wgt = nxt_wgt + 1
1075
1076	ELSE
1077	CALL ctl_stop( ' fld_weight : unable to read the file ' )
1078	ENDIF
1079
1080	CALL wrk_dealloc( jpi,jpj, data_src ) ! integer
1081	CALL wrk_dealloc( jpi,jpj, data_tmp )
1082	!
1083	END SUBROUTINE fld_weight
1084
1085
1086	SUBROUTINE fld_interp( num, clvar, kw, kk, dta, nrec )
1087	!!---------------------------------------------------------------------
1088	!! * ROUTINE fld_interp *
1089	!!
1090	!! ** Purpose : apply weights to input gridded data to create data
1091	!! on model grid
1092	!!----------------------------------------------------------------------
1093	INTEGER , INTENT(in ) :: num ! stream number
1094	CHARACTER(LEN=*) , INTENT(in ) :: clvar ! variable name
1095	INTEGER , INTENT(in ) :: kw ! weights number
1096	INTEGER , INTENT(in ) :: kk ! vertical dimension of kk
1097	REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: dta ! output field on model grid
1098	INTEGER , INTENT(in ) :: nrec ! record number to read (ie time slice)
1099	!!
1100	INTEGER, DIMENSION(3) :: rec1,recn ! temporary arrays for start and length
1101	INTEGER :: jk, jn, jm ! loop counters
1102	INTEGER :: ni, nj ! lengths
1103	INTEGER :: jpimin,jpiwid ! temporary indices
1104	INTEGER :: jpjmin,jpjwid ! temporary indices
1105	INTEGER :: jpi1,jpi2,jpj1,jpj2 ! temporary indices
1106	!!----------------------------------------------------------------------
1107	!
1108	!! for weighted interpolation we have weights at four corners of a box surrounding
1109	!! a model grid point, each weight is multiplied by a grid value (bilinear case)
1110	!! or by a grid value and gradients at the corner point (bicubic case)
1111	!! so we need to have a 4 by 4 subgrid surrounding each model point to cover both cases
1112
1113	!! sub grid from non-model input grid which encloses all grid points in this nemo process
1114	jpimin = ref_wgts(kw)%botleft(1)
1115	jpjmin = ref_wgts(kw)%botleft(2)
1116	jpiwid = ref_wgts(kw)%jpiwgt
1117	jpjwid = ref_wgts(kw)%jpjwgt
1118
1119	!! when reading in, expand this sub-grid by one halo point all the way round for calculating gradients
1120	rec1(1) = MAX( jpimin-1, 1 )
1121	rec1(2) = MAX( jpjmin-1, 1 )
1122	rec1(3) = 1
1123	recn(1) = MIN( jpiwid+2, ref_wgts(kw)%ddims(1)-rec1(1)+1 )
1124	recn(2) = MIN( jpjwid+2, ref_wgts(kw)%ddims(2)-rec1(2)+1 )
1125	recn(3) = kk
1126
1127	!! where we need to put it in the non-nemo grid fly_dta
1128	!! note that jpi1 and jpj1 only differ from 1 when jpimin and jpjmin are 1
1129	!! (ie at the extreme west or south of the whole input grid) and similarly for jpi2 and jpj2
1130	jpi1 = 2 + rec1(1) - jpimin
1131	jpj1 = 2 + rec1(2) - jpjmin
1132	jpi2 = jpi1 + recn(1) - 1
1133	jpj2 = jpj1 + recn(2) - 1
1134
1135	ref_wgts(kw)%fly_dta(:,:,:) = 0.0
1136	SELECT CASE( SIZE(ref_wgts(kw)%fly_dta(jpi1:jpi2,jpj1:jpj2,:),3) )
1137	CASE(1)
1138	CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%fly_dta(jpi1:jpi2,jpj1:jpj2,1), nrec, rec1, recn)
1139	CASE DEFAULT
1140	CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%fly_dta(jpi1:jpi2,jpj1:jpj2,:), nrec, rec1, recn)
1141	END SELECT
1142
1143	!! first four weights common to both bilinear and bicubic
1144	!! data_jpi, data_jpj have already been shifted to (1,1) corresponding to botleft
1145	!! note that we have to offset by 1 into fly_dta array because of halo
1146	dta(:,:,:) = 0.0
1147	DO jk = 1,4
1148	DO jn = 1, jpj
1149	DO jm = 1,jpi
1150	ni = ref_wgts(kw)%data_jpi(jm,jn,jk)
1151	nj = ref_wgts(kw)%data_jpj(jm,jn,jk)
1152	dta(jm,jn,:) = dta(jm,jn,:) + ref_wgts(kw)%data_wgt(jm,jn,jk) * ref_wgts(kw)%fly_dta(ni+1,nj+1,:)
1153	END DO
1154	END DO
1155	END DO
1156
1157	IF (ref_wgts(kw)%numwgt .EQ. 16) THEN
1158
1159	!! fix up halo points that we couldnt read from file
1160	IF( jpi1 == 2 ) THEN
1161	ref_wgts(kw)%fly_dta(jpi1-1,:,:) = ref_wgts(kw)%fly_dta(jpi1,:,:)
1162	ENDIF
1163	IF( jpi2 + jpimin - 1 == ref_wgts(kw)%ddims(1)+1 ) THEN
1164	ref_wgts(kw)%fly_dta(jpi2+1,:,:) = ref_wgts(kw)%fly_dta(jpi2,:,:)
1165	ENDIF
1166	IF( jpj1 == 2 ) THEN
1167	ref_wgts(kw)%fly_dta(:,jpj1-1,:) = ref_wgts(kw)%fly_dta(:,jpj1,:)
1168	ENDIF
1169	IF( jpj2 + jpjmin - 1 == ref_wgts(kw)%ddims(2)+1 .AND. jpj2 .lt. jpjwid+2 ) THEN
1170	ref_wgts(kw)%fly_dta(:,jpj2+1,:) = 2.0*ref_wgts(kw)%fly_dta(:,jpj2,:) - ref_wgts(kw)%fly_dta(:,jpj2-1,:)
1171	ENDIF
1172
1173	!! if data grid is cyclic we can do better on east-west edges
1174	!! but have to allow for whether first and last columns are coincident
1175	IF( ref_wgts(kw)%cyclic ) THEN
1176	rec1(2) = MAX( jpjmin-1, 1 )
1177	recn(1) = 1
1178	recn(2) = MIN( jpjwid+2, ref_wgts(kw)%ddims(2)-rec1(2)+1 )
1179	jpj1 = 2 + rec1(2) - jpjmin
1180	jpj2 = jpj1 + recn(2) - 1
1181	IF( jpi1 == 2 ) THEN
1182	rec1(1) = ref_wgts(kw)%ddims(1) - ref_wgts(kw)%overlap
1183	SELECT CASE( SIZE( ref_wgts(kw)%col(:,jpj1:jpj2,:),3) )
1184	CASE(1)
1185	CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%col(:,jpj1:jpj2,1), nrec, rec1, recn)
1186	CASE DEFAULT
1187	CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%col(:,jpj1:jpj2,:), nrec, rec1, recn)
1188	END SELECT
1189	ref_wgts(kw)%fly_dta(jpi1-1,jpj1:jpj2,:) = ref_wgts(kw)%col(1,jpj1:jpj2,:)
1190	ENDIF
1191	IF( jpi2 + jpimin - 1 == ref_wgts(kw)%ddims(1)+1 ) THEN
1192	rec1(1) = 1 + ref_wgts(kw)%overlap
1193	SELECT CASE( SIZE( ref_wgts(kw)%col(:,jpj1:jpj2,:),3) )
1194	CASE(1)
1195	CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%col(:,jpj1:jpj2,1), nrec, rec1, recn)
1196	CASE DEFAULT
1197	CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%col(:,jpj1:jpj2,:), nrec, rec1, recn)
1198	END SELECT
1199	ref_wgts(kw)%fly_dta(jpi2+1,jpj1:jpj2,:) = ref_wgts(kw)%col(1,jpj1:jpj2,:)
1200	ENDIF
1201	ENDIF
1202
1203	! gradient in the i direction
1204	DO jk = 1,4
1205	DO jn = 1, jpj
1206	DO jm = 1,jpi
1207	ni = ref_wgts(kw)%data_jpi(jm,jn,jk)
1208	nj = ref_wgts(kw)%data_jpj(jm,jn,jk)
1209	dta(jm,jn,:) = dta(jm,jn,:) + ref_wgts(kw)%data_wgt(jm,jn,jk+4) * 0.5 * &
1210	(ref_wgts(kw)%fly_dta(ni+2,nj+1,:) - ref_wgts(kw)%fly_dta(ni,nj+1,:))
1211	END DO
1212	END DO
1213	END DO
1214
1215	! gradient in the j direction
1216	DO jk = 1,4
1217	DO jn = 1, jpj
1218	DO jm = 1,jpi
1219	ni = ref_wgts(kw)%data_jpi(jm,jn,jk)
1220	nj = ref_wgts(kw)%data_jpj(jm,jn,jk)
1221	dta(jm,jn,:) = dta(jm,jn,:) + ref_wgts(kw)%data_wgt(jm,jn,jk+8) * 0.5 * &
1222	(ref_wgts(kw)%fly_dta(ni+1,nj+2,:) - ref_wgts(kw)%fly_dta(ni+1,nj,:))
1223	END DO
1224	END DO
1225	END DO
1226
1227	! gradient in the ij direction
1228	DO jk = 1,4
1229	DO jn = 1, jpj
1230	DO jm = 1,jpi
1231	ni = ref_wgts(kw)%data_jpi(jm,jn,jk)
1232	nj = ref_wgts(kw)%data_jpj(jm,jn,jk)
1233	dta(jm,jn,:) = dta(jm,jn,:) + ref_wgts(kw)%data_wgt(jm,jn,jk+12) * 0.25 * ( &
1234	(ref_wgts(kw)%fly_dta(ni+2,nj+2,:) - ref_wgts(kw)%fly_dta(ni ,nj+2,:)) - &
1235	(ref_wgts(kw)%fly_dta(ni+2,nj ,:) - ref_wgts(kw)%fly_dta(ni ,nj ,:)))
1236	END DO
1237	END DO
1238	END DO
1239	!
1240	END IF
1241	!
1242	END SUBROUTINE fld_interp
1243
1244
1245	FUNCTION ksec_week( cdday )
1246	!!---------------------------------------------------------------------
1247	!! * FUNCTION kshift_week *
1248	!!
1249	!! ** Purpose :
1250	!!---------------------------------------------------------------------
1251	CHARACTER(len=*), INTENT(in) :: cdday !3 first letters of the first day of the weekly file
1252	!!
1253	INTEGER :: ksec_week ! output variable
1254	INTEGER :: ijul !temp variable
1255	INTEGER :: ishift !temp variable
1256	CHARACTER(len=3),DIMENSION(7) :: cl_week
1257	!!----------------------------------------------------------------------
1258	cl_week = (/"sun","sat","fri","thu","wed","tue","mon"/)
1259	DO ijul = 1, 7
1260	IF( cl_week(ijul) == TRIM(cdday) ) EXIT
1261	END DO
1262	IF( ijul .GT. 7 ) CALL ctl_stop( 'ksec_week: wrong day for sdjf%cltype(6:8): '//TRIM(cdday) )
1263	!
1264	ishift = ijul * NINT(rday)
1265	!
1266	ksec_week = nsec_week + ishift
1267	ksec_week = MOD( ksec_week, 7*NINT(rday) )
1268	!
1269	END FUNCTION ksec_week
1270
1271	!!======================================================================
1272	END MODULE fldread2

Note: See TracBrowser for help on using the repository browser.

Download in other formats: