Oasis3-MCT
 All Classes Files Functions Variables Macros Pages
mod_oasis_namcouple.F90
Go to the documentation of this file.
1 
2 !> Reads the namcouple file for use in OASIS
3 
4 !> This code reads in the namcouple file and sets several variables
5 !> that are available to the rest of OASIS. Some of this code
6 !> is obsolete, and several input settings are deprecated.
7 !> This code is based on the original Oasis3 version and
8 !> will be rewritten at some point.
9 
11 
12 ! - - - - - - - - - - - - - - - - - - - - - - - - - - -
13 
14  USE mod_oasis_kinds
15  USE mod_oasis_data
17  USE mod_oasis_sys
18  USE mod_oasis_mpi
20 
21  IMPLICIT NONE
22 
23  private
24 
26 
27 ! NAMCOUPLE PUBLIC DATA
28 
29  INTEGER (kind=ip_intwp_p),PARAMETER :: jpeighty = 5000 !< max number of characters to be read
30  !< in each line of the file namcouple
31 
32  INTEGER(kind=ip_i4_p) ,public :: nnamcpl !< number of namcouple inputs
33  INTEGER(kind=ip_i4_p) ,public :: namruntim !< namcouple runtime
34  INTEGER(kind=ip_i4_p) ,public :: namlogprt !< namcouple nlogprt value
35  INTEGER(kind=ip_i4_p) ,public :: namtlogprt !< namcouple ntlogprt value
36 
37  character(len=jpeighty) ,public,pointer :: namsrcfld(:) !< list of src fields
38  character(len=jpeighty) ,public,pointer :: namdstfld(:) !< list of dst fields
39  character(len=ic_lvar) ,public,pointer :: namsrcgrd(:) !< src grid name
40  integer(kind=ip_i4_p) ,public,pointer :: namsrc_nx(:) !< src nx grid size
41  integer(kind=ip_i4_p) ,public,pointer :: namsrc_ny(:) !< src ny grid size
42  character(len=ic_lvar) ,public,pointer :: namdstgrd(:) !< dst grid name
43  integer(kind=ip_i4_p) ,public,pointer :: namdst_nx(:) !< dst nx grid size
44  integer(kind=ip_i4_p) ,public,pointer :: namdst_ny(:) !< dst ny grid size
45  INTEGER(kind=ip_i4_p) ,public,pointer :: namfldseq(:) !< SEQ value
46  INTEGER(kind=ip_i4_p) ,public,pointer :: namfldops(:) !< operation, ip_expout,...
47  INTEGER(kind=ip_i4_p) ,public,pointer :: namflddti(:) !< coupling period (secs)
48  INTEGER(kind=ip_i4_p) ,public,pointer :: namfldlag(:) !< coupling lag (secs)
49  INTEGER(kind=ip_i4_p) ,public,pointer :: namfldtrn(:) !< fields transform, ip_instant,...
50  integer(kind=ip_i4_p) ,public,pointer :: namfldcon(:) !< conserv fld operation
51  character(len=ic_med) ,public,pointer :: namfldcoo(:) !< conserv fld option (bfb, opt)
52  character(len=ic_long) ,public,pointer :: nammapfil(:) !< mapping file name
53  character(len=ic_med) ,public,pointer :: nammaploc(:) !< mapping location (src or dst pes)
54  character(len=ic_med) ,public,pointer :: nammapopt(:) !< mapping option (bfb, sum, or opt)
55  character(len=ic_med) ,public,pointer :: namrstfil(:) !< restart file name
56  character(len=ic_med) ,public,pointer :: naminpfil(:) !< input file name
57  logical ,public,pointer :: namchecki(:) !< checkin flag
58  logical ,public,pointer :: namchecko(:) !< checkout flag
59  REAL (kind=ip_realwp_p) ,public,pointer :: namfldsmu(:) !< src multiplier term
60  REAL (kind=ip_realwp_p) ,public,pointer :: namfldsad(:) !< src additive term
61  REAL (kind=ip_realwp_p) ,public,pointer :: namflddmu(:) !< dst multipler term
62  REAL (kind=ip_realwp_p) ,public,pointer :: namflddad(:) !< dst additive term
63 
64  character(len=ic_med) ,public,pointer :: namscrmet(:) !< scrip method (CONSERV, DISTWGT, BILINEAR, BICUBIC, GAUSWGT)
65  character(len=ic_med) ,public,pointer :: namscrnor(:) !< scrip conserv normalization (FRACAREA, DESTAREA, FRACNNEI)
66  character(len=ic_med) ,public,pointer :: namscrtyp(:) !< scrip mapping type (SCALAR, VECTOR)
67  character(len=ic_med) ,public,pointer :: namscrord(:) !< scrip conserve order (FIRST, SECOND)
68  character(len=ic_med) ,public,pointer :: namscrres(:) !< scrip search restriction (LATLON, LATITUDE)
69  REAL (kind=ip_realwp_p) ,public,pointer :: namscrvam(:) !< scrip gauss weight distance weighting for GAUSWGT
70  integer(kind=ip_i4_p) ,public,pointer :: namscrnbr(:) !< scrip number of neighbors for GAUSWGT and DISTWGT
71  integer(kind=ip_i4_p) ,public,pointer :: namscrbin(:) !< script number of search bins
72 
73  !--- derived ---
74  INTEGER(kind=ip_i4_p) ,public,pointer :: namsort2nn(:) !< sorted namcpl for sort, define nn order, computed later
75  INTEGER(kind=ip_i4_p) ,public,pointer :: namnn2sort(:) !< sorted namcpl for nn, define sort number, computed later
76 
77 !----------------------------------------------------------------
78 ! LOCAL ONLY BELOW HERE
79 !----------------------------------------------------------------
80 
81  integer(kind=ip_i4_p) :: nulin ! namcouple IO unit number
82  character(len=*),parameter :: cl_namcouple = 'namcouple'
83 
84 ! --- alloc_src
85  INTEGER (kind=ip_intwp_p) :: il_err
86 ! --- mod_unitncdf
87  LOGICAL :: lncdfgrd
88  LOGICAL :: lncdfrst
89 ! --- mod_label
90  CHARACTER(len=5), PARAMETER :: cgrdnam = 'grids'
91  CHARACTER(len=5), PARAMETER :: cmsknam = 'masks'
92  CHARACTER(len=5), PARAMETER :: csurnam = 'areas'
93  CHARACTER(len=5), PARAMETER :: crednam = 'maskr'
94  CHARACTER(len=4), PARAMETER :: cglonsuf = '.lon'
95  CHARACTER(len=4), PARAMETER :: cglatsuf = '.lat'
96  CHARACTER(len=4), PARAMETER :: crnlonsuf = '.clo'
97  CHARACTER(len=4), PARAMETER :: crnlatsuf = '.cla'
98  CHARACTER(len=4), PARAMETER :: cmsksuf = '.msk'
99  CHARACTER(len=4), PARAMETER :: csursuf = '.srf'
100  CHARACTER(len=4), PARAMETER :: cangsuf = '.ang'
101 ! --- mod_rainbow
102  LOGICAL,DIMENSION(:),ALLOCATABLE :: lmapp
103  LOGICAL,DIMENSION(:),ALLOCATABLE :: lsubg
104 ! --- mod_coast
105  INTEGER (kind=ip_intwp_p) :: nfcoast
106  LOGICAL :: lcoast
107 ! --- mod_timestep
108  INTEGER (kind=ip_intwp_p) :: ntime
109  INTEGER (kind=ip_intwp_p) :: niter
110  INTEGER (kind=ip_intwp_p) :: nitfn
111  INTEGER (kind=ip_intwp_p) :: nstep
112 ! --- mod_parameter
113  INTEGER (kind=ip_intwp_p) :: ig_nfield ! number of oasis coupled fields
114  INTEGER (kind=ip_intwp_p) :: ig_direct_nfield ! number of direct coupled fields
115  INTEGER (kind=ip_intwp_p) :: ig_total_nfield ! estimate of total fields
116  INTEGER (kind=ip_intwp_p) :: ig_final_nfield ! number of final fields
117  LOGICAL :: lg_oasis_field
118  INTEGER (kind=ip_intwp_p) :: ig_maxcomb
119  INTEGER (kind=ip_intwp_p) :: ig_maxnoa
120  INTEGER (kind=ip_intwp_p) :: ig_maxnfg
121 ! --- mod_printing
122  INTEGER(kind=ip_intwp_p) :: nlogprt
123 !---- Time statistics level printing
124  INTEGER(kind=ip_intwp_p) :: ntlogprt
125 ! --- mod_string
126  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: numlab
127  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: ig_numlab
128  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: nfexch
129  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: ig_ntrans
130  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: ig_total_ntrans
131  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: nlonbf
132  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: nlatbf
133  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: nlonaf
134  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: nlataf
135  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: nseqn
136  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: ig_total_nseqn
137  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: ig_freq
138  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: ig_lag
139  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: nlagn
140  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: ig_invert
141  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: ig_reverse
142  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: ig_number_field
143  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: ig_no_rstfile
144  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: ig_total_state
145  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: ig_local_trans
146  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: ig_grid_nbrbf
147  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: ig_grid_nbraf
148  INTEGER (kind=ip_intwp_p) :: ig_nbr_rstfile
149  INTEGER (kind=ip_intwp_p) :: ig_total_frqmin
150  LOGICAL ,DIMENSION(:),ALLOCATABLE :: lg_state
151  CHARACTER(len=jpeighty) ,DIMENSION(:),ALLOCATABLE :: cnaminp
152  CHARACTER(len=jpeighty) ,DIMENSION(:),ALLOCATABLE :: cnamout
153  CHARACTER(len=8) ,DIMENSION(:,:),ALLOCATABLE :: canal
154  CHARACTER(len=8) :: cg_c
155  CHARACTER(len=32) ,DIMENSION(:),ALLOCATABLE :: cg_name_rstfile
156  CHARACTER(len=32) ,DIMENSION(:),ALLOCATABLE :: cg_restart_file
157  CHARACTER(len=32) ,DIMENSION(:),ALLOCATABLE :: cficinp
158  CHARACTER(len=8) ,DIMENSION(:),ALLOCATABLE :: cficout
159  CHARACTER(len=32) ,DIMENSION(:),ALLOCATABLE :: cg_input_file
160  CHARACTER(len=jpeighty) ,DIMENSION(:),ALLOCATABLE :: cg_input_field
161  CHARACTER(len=jpeighty) ,DIMENSION(:),ALLOCATABLE :: cg_output_field
162  CHARACTER(len=8) ,DIMENSION(:),ALLOCATABLE :: cficbf
163  CHARACTER(len=8) ,DIMENSION(:),ALLOCATABLE :: cficaf
164  CHARACTER(len=8) ,DIMENSION(:),ALLOCATABLE :: cstate
165  CHARACTER(len=4) ,DIMENSION(:),ALLOCATABLE :: cga_locatorbf
166  CHARACTER(len=4) ,DIMENSION(:),ALLOCATABLE :: cga_locatoraf
167 ! --- mod_analysis
168  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: neighbor
169  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: ntronca
170  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: ncofld
171  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: neighborg
172  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nbofld
173  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nbnfld
174  INTEGER (kind=ip_intwp_p), DIMENSION(:,:), ALLOCATABLE :: nludat
175  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nlufil
176  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nlumap
177  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nmapfl
178  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nmapvoi
179  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nlusub
180  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nsubfl
181  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nsubvoi
182  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nluext
183  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nextfl
184  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nosper
185  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: notper
186  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nbins
187  INTEGER (kind=ip_intwp_p) :: nlucor
188  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nscripvoi
189  REAL (kind=ip_realwp_p), DIMENSION(:), ALLOCATABLE :: amskval
190  REAL (kind=ip_realwp_p), DIMENSION(:), ALLOCATABLE :: amskvalnew
191  REAL (kind=ip_realwp_p), DIMENSION(:,:), ALLOCATABLE :: acocoef
192  REAL (kind=ip_realwp_p), DIMENSION(:,:), ALLOCATABLE :: abocoef
193  REAL (kind=ip_realwp_p), DIMENSION(:,:), ALLOCATABLE :: abncoef
194  REAL (kind=ip_realwp_p), DIMENSION(:), ALLOCATABLE :: afldcoef
195  REAL (kind=ip_realwp_p), DIMENSION(:), ALLOCATABLE :: afldcobo
196  REAL (kind=ip_realwp_p), DIMENSION(:), ALLOCATABLE :: afldcobn
197  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cxordbf
198  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cyordbf
199  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cxordaf
200  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cyordaf
201  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cextmet
202  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cintmet
203  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cgrdtyp
204  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cfldtyp
205  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cfilfic
206  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cfilmet
207  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cconmet
208  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cconopt
209  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cfldcoa
210  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cfldfin
211  CHARACTER(len=8), DIMENSION(:,:),ALLOCATABLE :: ccofld
212  CHARACTER(len=8), DIMENSION(:,:),ALLOCATABLE :: cbofld
213  CHARACTER(len=8), DIMENSION(:,:),ALLOCATABLE :: cbnfld
214  CHARACTER(len=8), DIMENSION(:,:),ALLOCATABLE :: ccofic
215  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cdqdt
216  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cgrdmap
217  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cmskrd
218  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cgrdsub
219  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: ctypsub
220  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cgrdext
221  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: csper
222  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: ctper
223  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cmap_method
224  CHARACTER(len=ic_long), DIMENSION(:),ALLOCATABLE :: cmap_file
225  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cmaptyp
226  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cmapopt
227  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: corder
228  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cnorm_opt
229  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cfldtype
230  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: crsttype
231  CHARACTER(len=8) :: cfldcor
232  LOGICAL, DIMENSION(:),ALLOCATABLE :: lsurf
233 ! --- mod_anais
234  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: naismfl
235  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: naisgfl
236  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: naismvoi
237  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: naisgvoi
238  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: niwtm
239  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: niwtg
240  REAL (kind=ip_realwp_p), DIMENSION(:), ALLOCATABLE :: varmul
241  LOGICAL, DIMENSION(:), ALLOCATABLE :: linit
242 ! --- mod extrapol
243  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: niwtn
244  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nninnfl
245  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: niwtng
246  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nninnflg
247  LOGICAL, DIMENSION(:), ALLOCATABLE :: lextra
248  LOGICAL, DIMENSION(:), ALLOCATABLE :: lweight
249 !---------------------
250 !------------------------------------------------------------
251 CONTAINS
252 !------------------------------------------------------------
253 
254 !> Reads the namcouple
255 
256  SUBROUTINE oasis_namcouple_init()
257 
258  IMPLICIT NONE
259 
260  !-----------------------------------------------------------
261  integer(kind=ip_i4_p) :: n, nv, n1, n2, loc
262  integer(kind=ip_i4_p) :: ja, jf, jc
263  integer(kind=ip_i4_p) :: il_iost
264  integer(kind=ip_i4_p) :: maxunit
265  character(len=*),parameter :: subname='(oasis_namcouple_init)'
266  !-----------------------------------------------------------
267 
268  CALL oasis_unitget(nulin)
269  OPEN (unit = nulin,file =cl_namcouple,status='OLD', &
270  form ='FORMATTED', iostat = il_iost)
271 
272  IF (mpi_rank_global == 0) THEN
273  IF (il_iost .NE. 0) THEN
274  WRITE(nulprt1,*) subname,' ERROR opening namcouple file ',trim(cl_namcouple),&
275  ' with unit number ', nulin
276  WRITE (nulprt,'(a,i4)') ' abort by model ',compid
277  WRITE (nulprt,'(a)') ' error = ERROR opening namcouple file'
278  CALL oasis_abort()
279  ELSE
280  WRITE(nulprt1,*) subname,' open namcouple file ',trim(cl_namcouple),' with unit number ', &
281  nulin
282  ENDIF
283  ENDIF
284 
285  call inipar_alloc()
286  call alloc()
287  call inipar()
288  !
289  ! Close namcouple unit
290  close(nulin)
291 
292  CALL oasis_unitfree(nulin)
293 
294  IF (mpi_rank_global == 0) THEN
295  WRITE(nulprt1,*) subname,' allocating ig_final_nfield',ig_final_nfield
296  CALL oasis_flush(nulprt1)
297  ENDIF
298 
299  allocate(namsrcfld(ig_final_nfield), stat=il_err)
300  IF (il_err.NE.0) CALL prtout('Error in "namsrcfld" allocation of experiment module',il_err,1)
301 
302  allocate(namdstfld(ig_final_nfield), stat=il_err)
303  IF (il_err.NE.0) CALL prtout('Error in "namdstfld" allocation of experiment module',il_err,1)
304 
305  allocate(namsrcgrd(ig_final_nfield), stat=il_err)
306  IF (il_err.NE.0) CALL prtout('Error in "namsrcgrd" allocation of experiment module',il_err,1)
307 
308  allocate(namsrc_nx(ig_final_nfield), stat=il_err)
309  IF (il_err.NE.0) CALL prtout('Error in "namsrc_nx" allocation of experiment module',il_err,1)
310 
311  allocate(namsrc_ny(ig_final_nfield), stat=il_err)
312  IF (il_err.NE.0) CALL prtout('Error in "namsrc_ny" allocation of experiment module',il_err,1)
313 
314  allocate(namdstgrd(ig_final_nfield), stat=il_err)
315  IF (il_err.NE.0) CALL prtout('Error in "namdstgrd" allocation of experiment module',il_err,1)
316 
317  allocate(namdst_nx(ig_final_nfield), stat=il_err)
318  IF (il_err.NE.0) CALL prtout('Error in "namdst_nx" allocation of experiment module',il_err,1)
319 
320  allocate(namdst_ny(ig_final_nfield), stat=il_err)
321  IF (il_err.NE.0) CALL prtout('Error in "namdst_ny" allocation of experiment module',il_err,1)
322 
323  allocate(namfldseq(ig_final_nfield), stat=il_err)
324  IF (il_err.NE.0) CALL prtout('Error in "namfldseq" allocation of experiment module',il_err,1)
325 
326  allocate(namfldops(ig_final_nfield), stat=il_err)
327  IF (il_err.NE.0) CALL prtout('Error in "namfldops" allocation of experiment module',il_err,1)
328 
329  allocate(namfldtrn(ig_final_nfield), stat=il_err)
330  IF (il_err.NE.0) CALL prtout('Error in "namfldtrn" allocation of experiment module',il_err,1)
331 
332  allocate(namfldcon(ig_final_nfield), stat=il_err)
333  IF (il_err.NE.0) CALL prtout('Error in "namfldcon" allocation of experiment module',il_err,1)
334 
335  allocate(namfldcoo(ig_final_nfield), stat=il_err)
336  IF (il_err.NE.0) CALL prtout('Error in "namfldcoo" allocation of experiment module',il_err,1)
337 
338  allocate(namflddti(ig_final_nfield), stat=il_err)
339  IF (il_err.NE.0) CALL prtout('Error in "namflddti" allocation of experiment module',il_err,1)
340 
341  allocate(namfldlag(ig_final_nfield), stat=il_err)
342  IF (il_err.NE.0) CALL prtout('Error in "namfldlag" allocation of experiment module',il_err,1)
343 
344  allocate(nammapfil(ig_final_nfield), stat=il_err)
345  IF (il_err.NE.0) CALL prtout('Error in "nammapfil" allocation of experiment module',il_err,1)
346 
347  allocate(nammaploc(ig_final_nfield), stat=il_err)
348  IF (il_err.NE.0) CALL prtout('Error in "nammaploc" allocation of experiment module',il_err,1)
349 
350  allocate(nammapopt(ig_final_nfield), stat=il_err)
351  IF (il_err.NE.0) CALL prtout('Error in "nammapopt" allocation of experiment module',il_err,1)
352 
353  allocate(namrstfil(ig_final_nfield), stat=il_err)
354  IF (il_err.NE.0) CALL prtout('Error in "namrstfil" allocation of experiment module',il_err,1)
355 
356  allocate(naminpfil(ig_final_nfield), stat=il_err)
357  IF (il_err.NE.0) CALL prtout('Error in "naminpfil" allocation of experiment module',il_err,1)
358 
359  allocate(namsort2nn(ig_final_nfield), stat=il_err)
360  IF (il_err.NE.0) CALL prtout('Error in "namsort2nn" allocation of experiment module',il_err,1)
361 
362  allocate(namnn2sort(ig_final_nfield), stat=il_err)
363  IF (il_err.NE.0) CALL prtout('Error in "namnn2sort" allocation of experiment module',il_err,1)
364 
365  allocate(namchecki(ig_final_nfield), stat=il_err)
366  IF (il_err.NE.0) CALL prtout('Error in "namchecki" allocation of experiment module',il_err,1)
367 
368  allocate(namchecko(ig_final_nfield), stat=il_err)
369  IF (il_err.NE.0) CALL prtout('Error in "namchecko" allocation of experiment module',il_err,1)
370 
371  allocate(namfldsmu(ig_final_nfield), stat=il_err)
372  IF (il_err.NE.0) CALL prtout('Error in "namfldsmu" allocation of experiment module',il_err,1)
373 
374  allocate(namfldsad(ig_final_nfield), stat=il_err)
375  IF (il_err.NE.0) CALL prtout('Error in "namfldsad" allocation of experiment module',il_err,1)
376 
377  allocate(namflddmu(ig_final_nfield), stat=il_err)
378  IF (il_err.NE.0) CALL prtout('Error in "namflddmu" allocation of experiment module',il_err,1)
379 
380  allocate(namflddad(ig_final_nfield), stat=il_err)
381  IF (il_err.NE.0) CALL prtout('Error in "namflddad" allocation of experiment module',il_err,1)
382 
383  allocate(namscrmet(ig_final_nfield), stat=il_err)
384  IF (il_err.NE.0) CALL prtout('Error in "namscrmet" allocation of experiment module',il_err,1)
385 
386  allocate(namscrnor(ig_final_nfield), stat=il_err)
387  IF (il_err.NE.0) CALL prtout('Error in "namscrnor" allocation of experiment module',il_err,1)
388 
389  allocate(namscrtyp(ig_final_nfield), stat=il_err)
390  IF (il_err.NE.0) CALL prtout('Error in "namscrtyp" allocation of experiment module',il_err,1)
391 
392  allocate(namscrord(ig_final_nfield), stat=il_err)
393  IF (il_err.NE.0) CALL prtout('Error in "namscrord" allocation of experiment module',il_err,1)
394 
395  allocate(namscrres(ig_final_nfield), stat=il_err)
396  IF (il_err.NE.0) CALL prtout('Error in "namscrres" allocation of experiment module',il_err,1)
397 
398  allocate(namscrvam(ig_final_nfield), stat=il_err)
399  IF (il_err.NE.0) CALL prtout('Error in "namscrvam" allocation of experiment module',il_err,1)
400 
401  allocate(namscrnbr(ig_final_nfield), stat=il_err)
402  IF (il_err.NE.0) CALL prtout('Error in "namscrnbr" allocation of experiment module',il_err,1)
403 
404  allocate(namscrbin(ig_final_nfield), stat=il_err)
405  IF (il_err.NE.0) CALL prtout('Error in "namscrbin" allocation of experiment module',il_err,1)
406 
407  namsrcfld(:) = trim(cspval)
408  namdstfld(:) = trim(cspval)
409  namsrcgrd(:) = trim(cspval)
410  namsrc_nx(:) = 0
411  namsrc_ny(:) = 0
412  namdstgrd(:) = trim(cspval)
413  namdst_nx(:) = 0
414  namdst_ny(:) = 0
415  namfldseq(:) = -1
416  namfldops(:) = -1
417  namfldtrn(:) = ip_instant
418  namfldcon(:) = ip_cnone
419  namfldcoo(:) = "bfb"
420  namflddti(:) = -1
421  namfldlag(:) = 0
422  nammapfil(:) = "idmap"
423  nammaploc(:) = "src"
424  nammapopt(:) = "bfb"
425  namrstfil(:) = trim(cspval)
426  naminpfil(:) = trim(cspval)
427  namchecki(:) = .false.
428  namchecko(:) = .false.
429  namfldsmu(:) = 1.0_ip_realwp_p
430  namfldsad(:) = 0.0_ip_realwp_p
431  namflddmu(:) = 1.0_ip_realwp_p
432  namflddad(:) = 0.0_ip_realwp_p
433 
434  namscrmet(:) = trim(cspval)
435  namscrnor(:) = trim(cspval)
436  namscrtyp(:) = trim(cspval)
437  namscrord(:) = trim(cspval)
438  namscrres(:) = trim(cspval)
439  namscrvam(:) = 1.0_ip_realwp_p
440  namscrnbr(:) = -1
441  namscrbin(:) = -1
442 
443 ! maxunit = max(maxval(iga_unitmod),1024)
444  maxunit = 1024
445  IF (mpi_rank_global == 0) THEN
446  WRITE(nulprt1,*) subname,' maximum unit number = ',maxunit
447  CALL oasis_flush(nulprt1)
448  ENDIF
449 
450  call oasis_unitsetmin(maxunit)
451 
452  nnamcpl = ig_final_nfield
453  namruntim = ntime
454  namlogprt = nlogprt
455  namtlogprt = ntlogprt
456  do jf = 1,ig_final_nfield
457  namsrcfld(jf) = cg_input_field(jf)
458  namdstfld(jf) = cg_output_field(jf)
459  namfldseq(jf) = ig_total_nseqn(jf)
460  namfldops(jf) = ig_total_state(jf)
461  if (namfldops(jf) == ip_auxilary) then
462  IF (mpi_rank_global == 0) THEN
463  WRITE(nulprt1,*) subname,jf,'ERROR: AUXILARY NOT SUPPORTED'
464  WRITE (nulprt1,'(a)') ' error = STOP in oasis_namcouple_init'
465  CALL oasis_flush(nulprt1)
466  ENDIF
467  call oasis_abort()
468  endif
469  if (namfldops(jf) == ip_ignored) then
470  namfldops(jf) = ip_exported
471  IF (mpi_rank_global == 0) THEN
472  WRITE(nulprt1,*) subname,jf,'WARNING: IGNORED converted to EXPORTED'
473  CALL oasis_flush(nulprt1)
474  ENDIF
475  endif
476  if (namfldops(jf) == ip_ignout) then
477  namfldops(jf) = ip_expout
478  IF (mpi_rank_global == 0) THEN
479  WRITE(nulprt1,*) subname,jf,'WARNING: IGNOUT converted to EXPOUT'
480  CALL oasis_flush(nulprt1)
481  ENDIF
482  endif
483  namflddti(jf) = ig_freq(jf)
484  namfldlag(jf) = ig_lag(jf)
485  namfldtrn(jf) = ig_local_trans(jf)
486  namrstfil(jf) = trim(cg_restart_file(jf))
487  naminpfil(jf) = trim(cg_input_file(jf))
488  if (ig_number_field(jf) > 0) then
489  namsrcgrd(jf) = trim(cficbf(ig_number_field(jf)))
490  namsrc_nx(jf) = nlonbf(ig_number_field(jf))
491  namsrc_ny(jf) = nlatbf(ig_number_field(jf))
492  namdstgrd(jf) = trim(cficaf(ig_number_field(jf)))
493  namdst_nx(jf) = nlonaf(ig_number_field(jf))
494  namdst_ny(jf) = nlataf(ig_number_field(jf))
495  do ja = 1, ig_ntrans(ig_number_field(jf))
496 
497  if (canal(ja,ig_number_field(jf)) .EQ. 'SCRIPR') then
498  namscrmet(jf) = trim(cmap_method(ig_number_field(jf)))
499  namscrnor(jf) = trim(cnorm_opt(ig_number_field(jf)))
500  namscrtyp(jf) = trim(cfldtype(ig_number_field(jf)))
501  namscrord(jf) = trim(corder(ig_number_field(jf)))
502  namscrres(jf) = trim(crsttype(ig_number_field(jf)))
503  namscrvam(jf) = varmul(ig_number_field(jf))
504  namscrnbr(jf) = nscripvoi(ig_number_field(jf))
505  namscrbin(jf) = nbins(ig_number_field(jf))
506  IF (trim(namscrtyp(jf)) /= 'SCALAR') THEN
507  IF (mpi_rank_global == 0) THEN
508  WRITE(nulprt1,*) subname,jf,'WARNING: SCRIPR weights generation &
509  & supported only for SCALAR mapping, not '//trim(namscrtyp(jf))
510  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
511  WRITE (nulprt1,'(a)') ' error = ERROR in SCRIPR CFTYP option'
512  CALL oasis_flush(nulprt1)
513  ENDIF
514  CALL oasis_abort()
515  ENDIF
516 
517  elseif (canal(ja,ig_number_field(jf)) .EQ. 'MAPPING') then
518  nammapfil(jf) = trim(cmap_file(ig_number_field(jf)))
519  nammaploc(jf) = trim(cmaptyp(ig_number_field(jf)))
520  nammapopt(jf) = trim(cmapopt(ig_number_field(jf)))
521 
522  elseif (canal(ja,ig_number_field(jf)) .EQ. 'CONSERV') then
523  namfldcon(jf) = ip_cnone
524  namfldcoo(jf) = trim(cconopt(ig_number_field(jf)))
525  if (cconmet(ig_number_field(jf)) .EQ. 'GLOBAL') namfldcon(jf) = ip_cglobal
526  if (cconmet(ig_number_field(jf)) .EQ. 'GLBPOS') namfldcon(jf) = ip_cglbpos
527  if (cconmet(ig_number_field(jf)) .EQ. 'BASBAL') namfldcon(jf) = ip_cbasbal
528  if (cconmet(ig_number_field(jf)) .EQ. 'BASPOS') namfldcon(jf) = ip_cbaspos
529  if (namfldcon(jf) .EQ. ip_cnone) then
530  IF (mpi_rank_global == 0) THEN
531  WRITE(nulprt1,*) subname,jf,'WARNING: CONSERV option not supported: '//&
532  &trim(cconmet(ig_number_field(jf)))
533  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
534  WRITE (nulprt1,'(a)') ' error = ERROR in CONSERV option'
535  CALL oasis_flush(nulprt1)
536  ENDIF
537  CALL oasis_abort()
538  endif
539 
540  elseif (canal(ja,ig_number_field(jf)) .EQ. 'CHECKIN' ) then
541  namchecki(jf) = .true.
542 
543  elseif (canal(ja,ig_number_field(jf)) .EQ. 'CHECKOUT') then
544  namchecko(jf) = .true.
545 
546  elseif (canal(ja,ig_number_field(jf)) .EQ. 'BLASOLD') then
547  namfldsmu(jf) = afldcobo(ig_number_field(jf))
548  do jc = 1, nbofld(ig_number_field(jf))
549  if (trim(cbofld(jc,ig_number_field(jf))) == 'CONSTANT') then
550  namfldsad(jf) = abocoef(jc,ig_number_field(jf))
551  else
552  IF (mpi_rank_global == 0) THEN
553  WRITE(nulprt1,*) subname,jf,'ERROR: BLASOLD only supports CONSTANT: '//&
554  &trim(cbofld(jc,ig_number_field(jf)))
555  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
556  WRITE (nulprt1,'(a)') ' error = ERROR in BLASOLD option'
557  CALL oasis_flush(nulprt1)
558  ENDIF
559  call oasis_abort()
560  endif
561  enddo
562 
563  elseif (canal(ja,ig_number_field(jf)) .EQ. 'BLASNEW') then
564  namflddmu(jf) = afldcobn(ig_number_field(jf))
565  do jc = 1, nbnfld(ig_number_field(jf))
566  if (trim(cbnfld(jc,ig_number_field(jf))) == 'CONSTANT') then
567  namflddad(jf) = abncoef(jc,ig_number_field(jf))
568  else
569  IF (mpi_rank_global == 0) THEN
570  WRITE(nulprt1,*) subname,jf,'ERROR: BLASNEW only supports CONSTANTS: '//&
571  &trim(cbofld(jc,ig_number_field(jf)))
572  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
573  WRITE (nulprt1,'(a)') ' error = ERROR in BLASNEW option'
574  CALL oasis_flush(nulprt1)
575  ENDIF
576  call oasis_abort()
577  endif
578  enddo
579 
580  endif ! canal
581  enddo ! ig_ntrans
582  endif ! ig_number_field
583  enddo ! ig_final_nfield
584 
585  IF (mpi_rank_global == 0) THEN
586  WRITE(nulprt1,*) ' '
587  WRITE(nulprt1,*) subname,'namlogprt ',namlogprt
588  WRITE(nulprt1,*) ' '
589  DO n = 1,nnamcpl
590  WRITE(nulprt1,*) subname,n,'namsrcfld ',trim(namsrcfld(n))
591  WRITE(nulprt1,*) subname,n,'namdstfld ',trim(namdstfld(n))
592  WRITE(nulprt1,*) subname,n,'namsrcgrd ',trim(namsrcgrd(n))
593  WRITE(nulprt1,*) subname,n,'namsrc_nx ',namsrc_nx(n)
594  WRITE(nulprt1,*) subname,n,'namsrc_ny ',namsrc_ny(n)
595  WRITE(nulprt1,*) subname,n,'namdstgrd ',trim(namdstgrd(n))
596  WRITE(nulprt1,*) subname,n,'namdst_nx ',namdst_nx(n)
597  WRITE(nulprt1,*) subname,n,'namdst_ny ',namdst_ny(n)
598  WRITE(nulprt1,*) subname,n,'namfldseq ',namfldseq(n)
599  WRITE(nulprt1,*) subname,n,'namfldops ',namfldops(n)
600  WRITE(nulprt1,*) subname,n,'namfldtrn ',namfldtrn(n)
601  WRITE(nulprt1,*) subname,n,'namfldcon ',namfldcon(n)
602  WRITE(nulprt1,*) subname,n,'namfldcoo ',trim(namfldcoo(n))
603  WRITE(nulprt1,*) subname,n,'namflddti ',namflddti(n)
604  WRITE(nulprt1,*) subname,n,'namfldlag ',namfldlag(n)
605  WRITE(nulprt1,*) subname,n,'nammapfil ',trim(nammapfil(n))
606  WRITE(nulprt1,*) subname,n,'nammaploc ',trim(nammaploc(n))
607  WRITE(nulprt1,*) subname,n,'nammapopt ',trim(nammapopt(n))
608  WRITE(nulprt1,*) subname,n,'namrstfil ',trim(namrstfil(n))
609  WRITE(nulprt1,*) subname,n,'naminpfil ',trim(naminpfil(n))
610  WRITE(nulprt1,*) subname,n,'namchecki ',namchecki(n)
611  WRITE(nulprt1,*) subname,n,'namchecko ',namchecko(n)
612  WRITE(nulprt1,*) subname,n,'namfldsmu ',namfldsmu(n)
613  WRITE(nulprt1,*) subname,n,'namfldsad ',namfldsad(n)
614  WRITE(nulprt1,*) subname,n,'namflddmu ',namflddmu(n)
615  WRITE(nulprt1,*) subname,n,'namflddad ',namflddad(n)
616  WRITE(nulprt1,*) subname,n,'namscrmet ',trim(namscrmet(n))
617  WRITE(nulprt1,*) subname,n,'namscrnor ',trim(namscrnor(n))
618  WRITE(nulprt1,*) subname,n,'namscrtyp ',trim(namscrtyp(n))
619  WRITE(nulprt1,*) subname,n,'namscrord ',trim(namscrord(n))
620  WRITE(nulprt1,*) subname,n,'namscrres ',trim(namscrres(n))
621  WRITE(nulprt1,*) subname,n,'namscrvam ',namscrvam(n)
622  WRITE(nulprt1,*) subname,n,'namscrnbr ',namscrnbr(n)
623  WRITE(nulprt1,*) subname,n,'namscrbin ',namscrbin(n)
624  WRITE(nulprt1,*) ' '
625  CALL oasis_flush(nulprt1)
626  ENDDO
627  ENDIF
628 
629  !--- compute seq sort ---
630  namsort2nn(:) = -1
631  do nv = 1,nnamcpl
632  loc = nv ! default at end
633  n1 = 1
634  do while (loc == nv .and. n1 < nv)
635  if (namfldseq(nv) < namfldseq(namsort2nn(n1))) loc = n1
636  n1 = n1 + 1
637  enddo
638  ! nv goes into loc location, shift then set
639  do n1 = nv,loc+1,-1
640  namsort2nn(n1) = namsort2nn(n1-1)
641  enddo
642  namsort2nn(loc) = nv
643  enddo
644 
645  do nv = 1,nnamcpl
646  namnn2sort(namsort2nn(nv)) = nv
647  enddo
648 
649  IF (mpi_rank_global == 0) THEN
650  DO nv = 1,nnamcpl
651  n1 = namsort2nn(nv)
652  n2 = namnn2sort(nv)
653  WRITE(nulprt1,*) subname,' sort ',nv,n1,n2,namfldseq(n1)
654  CALL oasis_flush(nulprt1)
655  ENDDO
656  ENDIF
657 
658 
659  !--- check they are sorted ---
660  do n = 2,nnamcpl
661  if (namfldseq(namsort2nn(n)) < namfldseq(namsort2nn(n-1))) then
662  IF (mpi_rank_global == 0) THEN
663  WRITE(nulprt1,*) subname,' ERROR in seq sort'
664  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
665  WRITE (nulprt1,'(a)') ' error = ERROR in seq sort'
666  CALL oasis_flush(nulprt1)
667  ENDIF
668  call oasis_abort()
669  endif
670  enddo
671 
672  call dealloc()
673 
674  ! call oasis_debug_exit(subname)
675 
676 END SUBROUTINE oasis_namcouple_init
677 
678 !===============================================================================
679 
680 SUBROUTINE inipar_alloc()
681 !****
682 ! *****************************
683 ! * OASIS ROUTINE - LEVEL 0 *
684 ! * ------------- ------- *
685 ! *****************************
686 
687 !**** *inipar_alloc* - Get main run parameters to allocate arrays
688 
689 ! Purpose:
690 ! -------
691 ! Reads out run parameters.
692 
693 !** Interface:
694 ! ---------
695 ! *CALL* *inipar_alloc*
696 
697 ! Input:
698 ! -----
699 ! None
700 
701 ! Output:
702 ! ------
703 ! None
704 !
705 ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
706 
707  IMPLICIT NONE
708 
709  !* ---------------------------- Local declarations --------------------
710 
711  CHARACTER*5000 clline, clline_aux, clvari
712  CHARACTER*9 clword, clfield, clstring, clmod, clchan
713  CHARACTER*3 clind
714  CHARACTER*2 cldeb
715  CHARACTER*1 clequa
716  CHARACTER*8 clwork
717  CHARACTER*8 clstrg
718  CHARACTER*7 cl_bsend
719 
720  CHARACTER(len=32), DIMENSION(:), ALLOCATABLE :: cl_aux
721  INTEGER (kind=ip_intwp_p) il_varid, il_len, il_err, il_maxanal
722  INTEGER (kind=ip_intwp_p) nlonbf_notnc, nlatbf_notnc, &
723  nlonaf_notnc, nlataf_notnc
724  INTEGER (kind=ip_intwp_p) iind, il_redu, ib, il_aux, il_auxbf, &
725  il_auxaf, istatus, il_id
726  integer (kind=ip_intwp_p) :: ja,jz,jm,jf,ilen
727  integer (kind=ip_intwp_p) :: ig_clim_maxport
728  logical :: lg_bsend,endflag
729  character(len=*),parameter :: subname='(mod_oasis_namcouple:inipar_alloc)'
730 
731  !* ---------------------------- Poema verses --------------------------
732 
733  ! call oasis_debug_enter(subname)
734 
735  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
736 
737  !* 1. Get basic info for the simulation
738  ! ---------------------------------
739 
740  IF (mpi_rank_global == 0) THEN
741  WRITE (unit = nulprt1,fmt = *)' '
742  WRITE (unit = nulprt1,fmt = *)' ROUTINE inipar_alloc - Level 0'
743  WRITE (unit = nulprt1,fmt = *)' ******************** *******'
744  WRITE (unit = nulprt1,fmt = *)' '
745  WRITE (unit = nulprt1,fmt = *)' Initialization of run parameters'
746  WRITE (unit = nulprt1,fmt = *)' '
747  WRITE (unit = nulprt1,fmt = *)' Reading input file namcouple'
748  WRITE (unit = nulprt1,fmt = *)' '
749  WRITE (unit = nulprt1,fmt = *)' '
750  CALL oasis_flush(nulprt1)
751  ENDIF
752 
753  !* Initialization
754  ig_direct_nfield = 0
755  ig_nfield = 0
756  lg_oasis_field = .true.
757  !* Initialize character keywords to locate appropriate input
758 
759  clfield = ' $NFIELDS'
760  clchan = ' $CHANNEL'
761  clstring = ' $STRINGS'
762  clmod = ' $NBMODEL'
763 
764  !* Get number of models involved in this simulation
765 
766  rewind nulin
767 100 CONTINUE
768  READ (unit = nulin,fmt = 1001,END = 140) clword
769  IF (clword .NE. clmod) go to 100
770  IF (mpi_rank_global == 0) THEN
771  WRITE (unit = nulprt1,fmt = *) ' ***WARNING***'
772  WRITE (unit = nulprt1,fmt = *) 'Information below $NBMODEL'
773  WRITE (unit = nulprt1,fmt = *) 'is obsolete in OASIS3-MCT'
774  WRITE (unit = nulprt1,fmt = *) 'It will not be read and will not be used'
775  CALL oasis_flush(nulprt1)
776  ENDIF
777 
778 140 CONTINUE
779 
780  ! --> Get the message passing technique we are using
781 
782  rewind nulin
783 120 CONTINUE
784  READ (unit = nulin,fmt = 1001,END = 130) clword
785  IF (clword .NE. clchan) go to 120
786  IF (mpi_rank_global == 0) THEN
787  WRITE (unit = nulprt1,fmt = *) ' ***WARNING***'
788  WRITE (unit = nulprt1,fmt = *) 'Information below $CHANNEL'
789  WRITE (unit = nulprt1,fmt = *) 'is obsolete in OASIS3-MCT'
790  WRITE (unit = nulprt1,fmt = *) 'It will not be read and will not be used'
791  CALL oasis_flush(nulprt1)
792  ENDIF
793 
794 130 CONTINUE
795 
796  !* Formats
797 
798 1001 FORMAT(a9)
799 1002 FORMAT(a5000)
800 
801 
802  !* 2. Get field information
803  ! --------------------
804 
805  !* Read total number of fields exchanged by this OASIS process
806 
807  rewind nulin
808 200 CONTINUE
809  READ (unit = nulin,fmt = 2001,END = 210) clword
810  IF (clword .NE. clfield) go to 200
811  READ (unit = nulin,fmt = 2002) clline
812  CALL parse(clline, clvari, 1, jpeighty, ilen)
813  IF (ilen .LE. 0) THEN
814  IF (mpi_rank_global == 0) THEN
815  WRITE (unit = nulprt1,fmt = *) ' ***WARNING***'
816  WRITE (unit = nulprt1,fmt = *) &
817  ' Nothing on input for $NFIELDS '
818  WRITE (unit = nulprt1,fmt = *) ' Default value will be used '
819  WRITE (unit = nulprt1,fmt = *) ' '
820  CALL oasis_flush(nulprt1)
821  ENDIF
822  ELSE
823  READ (clvari,fmt = 2003) ig_total_nfield
824  ENDIF
825 
826  !* Print out the total number of fields exchanged by this OASIS process
827 
828  CALL prtout &
829  ('The maximum number of exchanged fields set in namcouple is nfield =', &
830  ig_total_nfield, 1)
831 
832  !* Alloc field number array
833 
834  ALLOCATE (ig_number_field(ig_total_nfield),stat=il_err)
835  IF (il_err.NE.0) CALL prtout &
836  ('Error: ig_number_field allocation of inipar_alloc',il_err,1)
837  ig_number_field(:)=0
838 
839  !* Alloc field status array (logical indicating if the field goes through
840  !* Oasis or not)
841 
842  ALLOCATE (lg_state(ig_total_nfield), stat=il_err)
843  IF (il_err.NE.0) CALL prtout &
844  ('Error: lg_state allocation of inipar_alloc',il_err,1)
845  lg_state(:)=.false.
846 
847  !* Alloc status of all the fields
848 
849  ALLOCATE (ig_total_state(ig_total_nfield), stat=il_err)
850  IF (il_err.NE.0) CALL prtout &
851  ('Error: ig_total_state allocation of inipar_alloc',il_err,1)
852  ig_total_state(:)=0
853 
854  !* Alloc input field name array
855 
856  ALLOCATE (cg_output_field(ig_total_nfield), stat=il_err)
857  IF (il_err.NE.0) CALL prtout &
858  ('Error: cg_output_field allocation of inipar_alloc',il_err,1)
859  cg_output_field(:)=' '
860 
861  !* Alloc number of analyses array
862 
863  ALLOCATE (ig_total_ntrans(ig_total_nfield),stat=il_err)
864  IF (il_err.NE.0) CALL prtout &
865  ('Error: ig_total_ntrans"allocation of inipar_alloc',il_err,1)
866  ig_total_ntrans(:) = 0
867 
868  !* Alloc array of restart file names, input and output file names
869 
870  ALLOCATE (cg_restart_file(ig_total_nfield),stat=il_err)
871  IF (il_err.NE.0) CALL prtout &
872  ('Error: cg_restart_FILE allocation of inipar_alloc',il_err,1)
873  cg_restart_file(:)=' '
874  ALLOCATE (cg_input_file(ig_total_nfield), stat=il_err)
875  IF (il_err.NE.0) CALL prtout &
876  ('Error in "cg_input_file"allocation of inipar_alloc',il_err,1)
877  cg_input_file(:)=' '
878 
879  !* Alloc array of source and target locator prefix
880 
881  ALLOCATE (cga_locatorbf(ig_total_nfield),stat=il_err)
882  IF (il_err.NE.0) CALL prtout &
883  ('Error: cga_locatorbf allocation of inipar_alloc',il_err,1)
884  cga_locatorbf(:)=' '
885 
886  ALLOCATE (cga_locatoraf(ig_total_nfield),stat=il_err)
887  IF (il_err.NE.0) CALL prtout &
888  ('Error: cga_locatoraf allocation of inipar_alloc',il_err,1)
889  cga_locatoraf(:)=' '
890 
891  !* Get information for all fields
892 
893  rewind nulin
894 220 CONTINUE
895  READ (unit = nulin,fmt = 2001,END = 230) clword
896  IF (clword .NE. clstring) go to 220
897 
898  !* Loop on total number of fields
899 
900  ig_final_nfield = 0
901 
902  DO 240 jf = 1, ig_total_nfield
903 
904  !* First line
905 
906  READ (unit = nulin,fmt = 2002, end=241) clline
907  CALL parse(clline, clvari, 1, jpeighty, ilen, endflag=endflag)
908  if (endflag .EQV. .true.) goto 241
909  IF (trim(clvari) .EQ. " ") goto 232
910  IF (trim(clvari) .eq. "$END") goto 241
911  !* Get output field symbolic name
912  IF (mpi_rank_global == 0) THEN
913  write(nulprt1,*) 'parsing: ',trim(clline)
914  CALL oasis_flush(nulprt1)
915  ENDIF
916  CALL parse(clline, clvari, 2, jpeighty, ilen)
917  cg_output_field(jf) = clvari
918  !* Get total number of analysis
919  CALL parse(clline, clvari, 5, jpeighty, ilen)
920  READ (clvari,fmt = 2003) ig_total_ntrans(jf)
921  !* Get field STATUS for OUTPUT fields
922  CALL parse(clline, clvari, 6, jpeighty, ilen)
923  IF (clvari(1:6) .EQ. 'OUTPUT') THEN
924  ig_direct_nfield = ig_direct_nfield + 1
925  lg_state(jf) = .false.
926  ig_total_state(jf) = ip_output
927  ELSE
928  !* Get field status (direct or through oasis) and the number
929  !* of direct and indirect fields if not PIPE nor NONE
930  CALL parse(clline, clvari, 7, jpeighty, ilen)
931  IF (clvari(1:8).eq.'EXPORTED') THEN
932  ig_nfield = ig_nfield + 1
933  lg_state(jf) = .true.
934  ig_number_field(jf) = ig_nfield
935  ig_total_state(jf) = ip_exported
936  CALL parse(clline, clvari, 6, jpeighty, ilen)
937  !* Get restart file name
938  cg_restart_file(jf) = clvari
939  !* Get restart file name
940  ELSEIF (clvari(1:6) .eq. 'OUTPUT' ) THEN
941  ig_direct_nfield = ig_direct_nfield + 1
942  lg_state(jf) = .false.
943  ig_total_state(jf) = ip_output
944  CALL parse(clline, clvari, 6, jpeighty, ilen)
945  cg_restart_file(jf) = clvari
946  ELSEIF (clvari(1:7) .eq. 'IGNORED' ) THEN
947  ig_direct_nfield = ig_direct_nfield + 1
948  lg_state(jf) = .false.
949  ig_total_state(jf) = ip_ignored
950  CALL parse(clline, clvari, 6, jpeighty, ilen)
951  !* Get restart file name
952  cg_restart_file(jf) = clvari
953  ELSEIF (clvari(1:6) .eq. 'EXPOUT') THEN
954  ig_nfield = ig_nfield + 1
955  lg_state(jf) = .true.
956  ig_number_field(jf) = ig_nfield
957  ig_total_state(jf) = ip_expout
958  CALL parse(clline, clvari, 6, jpeighty, ilen)
959  !* Get restart file name
960  cg_restart_file(jf) = clvari
961  ELSEIF (clvari(1:6) .eq. 'IGNOUT' ) THEN
962  ig_direct_nfield = ig_direct_nfield + 1
963  lg_state(jf) = .false.
964  ig_total_state(jf) = ip_ignout
965  CALL parse(clline, clvari, 6, jpeighty, ilen)
966  !* Get restart file name
967  cg_restart_file(jf) = clvari
968  ELSEIF (clvari(1:9).eq. 'AUXILARY') THEN
969  ig_nfield = ig_nfield + 1
970  lg_state(jf) = .true.
971  ig_number_field(jf) = ig_nfield
972  ig_total_state(jf) = ip_auxilary
973  CALL parse(clline, clvari, 6, jpeighty, ilen)
974  !* Get restart file name
975  cg_restart_file(jf) = clvari
976  ELSEIF (clvari(1:5) .eq. 'INPUT') THEN
977  ig_direct_nfield = ig_direct_nfield + 1
978  lg_state(jf) = .false.
979  ig_total_state(jf) = ip_input
980  CALL parse(clline, clvari, 6, jpeighty, ilen)
981  !* Get input file name
982  cg_input_file(jf) = clvari
983  ENDIF
984  ENDIF
985  IF (lg_state(jf)) THEN
986  IF (ig_total_ntrans(jf) .eq. 0) THEN
987  IF (mpi_rank_global == 0) THEN
988  WRITE (unit = nulprt1,fmt = *) &
989  'If there is no analysis for the field',jf, &
990  'then the status must not be "EXPORTED"'
991  WRITE (unit = nulprt1,fmt = *)' "AUXILARY" or "EXPOUT" '
992  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
993  WRITE (nulprt1,'(a)') ' error = STOP in inipar_alloc'
994  CALL oasis_flush(nulprt1)
995  ENDIF
996  CALL oasis_abort()
997  ENDIF
998  READ (unit = nulin,fmt = 2002) clline
999  CALL skip(clline, jpeighty)
1000  READ (unit = nulin,fmt = 2002) clline
1001  CALL skip(clline, jpeighty)
1002  READ (unit = nulin,fmt = 2002)clline_aux
1003  DO ja=1,ig_total_ntrans(jf)
1004  CALL parse(clline_aux, clvari, ja, jpeighty, ilen)
1005  IF (clvari.eq.'CORRECT'.or.clvari.eq.'BLASOLD'.or. &
1006  clvari.eq.'BLASNEW') THEN
1007  READ (unit = nulin,fmt = 2002) clline
1008  CALL parse(clline, clvari, 2, jpeighty, ilen)
1009  READ(clvari,fmt = 2003) il_aux
1010  DO ib = 1, il_aux
1011  READ (unit = nulin,fmt = 2002) clline
1012  CALL skip(clline, jpeighty)
1013  ENDDO
1014  ELSE IF (clvari.eq.'NOINTERP') THEN
1015  CONTINUE
1016  ELSE
1017  READ (unit = nulin,fmt = 2002) clline
1018  CALL skip(clline, jpeighty)
1019  ENDIF
1020  ENDDO
1021  ELSE
1022  IF (ig_total_state(jf) .ne. ip_input) THEN
1023  READ (unit = nulin,fmt = 2002) clline
1024  CALL skip(clline, jpeighty)
1025  ENDIF
1026  IF (ig_total_state(jf) .ne. ip_input .and. &
1027  ig_total_ntrans(jf) .gt. 0 ) THEN
1028  READ (unit = nulin,fmt = 2002) clline
1029  CALL parse(clline, clvari, 1, jpeighty, ilen)
1030  IF (clvari(1:8) .ne. 'LOCTRANS') THEN
1031  IF (mpi_rank_global == 0) THEN
1032  WRITE (unit = nulprt1,fmt = *) &
1033  'You want a transformation which is not available !'
1034  WRITE (unit = nulprt1,fmt = *) &
1035  'Only local transformations are available for '
1036  WRITE (unit = nulprt1,fmt = *) &
1037  'fields exchanged directly or output fields '
1038  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
1039  WRITE (nulprt1,'(a)') ' error = STOP in inipar_alloc'
1040  CALL oasis_flush(nulprt1)
1041  ENDIF
1042  CALL oasis_abort()
1043  ENDIF
1044  DO ja=1,ig_total_ntrans(jf)
1045  READ (unit = nulin,fmt = 2002) clline
1046  CALL skip(clline, jpeighty)
1047  ENDDO
1048  ENDIF
1049  ENDIF
1050 
1051  ig_final_nfield = ig_final_nfield + 1
1052 
1053 240 CONTINUE
1054 
1055  !* Verify we're at the end of the namcouple, if not STOP (tcraig, june 2012)
1056 243 READ (unit = nulin,fmt = 2002, end=242) clline
1057  CALL skip(clline, jpeighty,endflag=endflag)
1058  if (endflag .EQV. .true.) goto 242
1059  CALL parse(clline, clvari, 1, jpeighty, ilen)
1060  IF (trim(clvari) .eq. "$END") goto 243
1061 
1062  IF (mpi_rank_global == 0) THEN
1063  WRITE (unit = nulprt1,fmt = *) ' ***WARNING***'
1064  WRITE (unit = nulprt1,fmt = *) &
1065  ' NFIELDS too small, increase it in namcouple'
1066  WRITE (unit = nulprt1,fmt = *) ' '
1067  WRITE (unit = nulprt1,fmt = *) ' '
1068  WRITE (unit = nulprt1,fmt = *) &
1069  ' We STOP!!! Check the file namcouple'
1070  WRITE (unit = nulprt1,fmt = *) ' '
1071  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
1072  WRITE (nulprt1,'(a)') ' error = STOP in inipar_alloc'
1073  CALL oasis_flush(nulprt1)
1074  ENDIF
1075  CALL oasis_abort()
1076 
1077 241 CONTINUE
1078  IF (mpi_rank_global == 0) then
1079  WRITE (nulprt1,'(a,i6)') ' found namcouple couplings = ',ig_final_nfield
1080  ENDIF
1081 
1082 242 CONTINUE
1083  IF (ig_nfield.eq.0) THEN
1084  lg_oasis_field = .false.
1085  IF (mpi_rank_global == 0) THEN
1086  WRITE (nulprt1,*)'==> All the fields are exchanged directly'
1087  CALL oasis_flush(nulprt1)
1088  ENDIF
1089  ENDIF
1090 
1091 
1092  !* Number of different restart files
1093 
1094  allocate (cl_aux(ig_final_nfield))
1095  cl_aux(:)=' '
1096  DO jf = 1,ig_final_nfield
1097  IF (jf.eq.1) THEN
1098  cl_aux(1) = cg_restart_file(1)
1099  il_aux = 1
1100  ELSEIF (jf.gt.1) THEN
1101  IF (all(cl_aux.ne.cg_restart_file(jf))) THEN
1102  il_aux = il_aux + 1
1103  cl_aux(il_aux) = cg_restart_file(jf)
1104  ENDIF
1105  ENDIF
1106  ENDDO
1107  deallocate(cl_aux)
1108  ig_nbr_rstfile = il_aux
1109 
1110  IF (lg_oasis_field) THEN
1111 
1112  !* Alloc array needed for INTERP and initialize them
1113 
1114  ALLOCATE (cintmet(ig_nfield),stat=il_err)
1115  IF (il_err.NE.0) CALL prtout &
1116  ('Error: cintmet allocation of inipar_alloc',il_err,1)
1117  ALLOCATE (naismfl(ig_nfield),stat=il_err)
1118  IF (il_err.NE.0) CALL prtout &
1119  ('Error: naismfl allocation of inipar_alloc',il_err,1)
1120  ALLOCATE (naismvoi(ig_nfield),stat=il_err)
1121  IF (il_err.NE.0) CALL prtout &
1122  ('Error: naismvoi allocation of inipar_alloc',il_err,1)
1123  ALLOCATE (naisgfl(ig_nfield),stat=il_err)
1124  IF (il_err.NE.0) CALL prtout &
1125  ('Error: naisgfl allocation of inipar_alloc',il_err,1)
1126  ALLOCATE (naisgvoi(ig_nfield),stat=il_err)
1127  IF (il_err.NE.0) CALL prtout &
1128  ('Error: naisgvoi allocation of inipar_alloc',il_err,1)
1129  cintmet(:)=' '
1130  naismfl(:) = 1
1131  naismvoi(:) = 1
1132  naisgfl(:) = 1
1133  naisgvoi(:) = 1
1134  !
1135  !* Alloc arrays needed for EXTRAP and initialize them
1136  !
1137  ALLOCATE (cextmet(ig_nfield),stat=il_err)
1138  IF (il_err.NE.0) CALL prtout &
1139  ('Error: cextmet allocation of inipar_alloc',il_err,1)
1140  ALLOCATE (nninnfl(ig_nfield),stat=il_err)
1141  IF (il_err.NE.0) CALL prtout &
1142  ('Error: nninnfl allocation of inipar_alloc',il_err,1)
1143  ALLOCATE (nninnflg(ig_nfield),stat=il_err)
1144  IF (il_err.NE.0) CALL prtout &
1145  ('Error: nninnflg allocation of inipar_alloc',il_err,1)
1146  ALLOCATE (neighbor(ig_nfield), stat=il_err)
1147  IF (il_err.NE.0) CALL prtout &
1148  ('Error: neighbor allocation of inipar_alloc',il_err,1)
1149  ALLOCATE (nextfl(ig_nfield),stat=il_err)
1150  IF (il_err.NE.0) CALL prtout &
1151  ('Error: nextfl allocation of inipar_alloc',il_err,1)
1152  cextmet(:)=' '
1153  nninnfl(:) = 1
1154  nninnflg(:) = 1
1155  neighbor(:) = 1
1156  nextfl(:) = 1
1157  !
1158  !* Alloc arrays needed for BLAS... analyses and initialize them
1159  !
1160  ALLOCATE (nbofld(ig_nfield), stat=il_err)
1161  IF (il_err.NE.0) CALL prtout &
1162  ('Error: nbofld allocation of inipar_alloc',il_err,1)
1163  ALLOCATE (nbnfld(ig_nfield), stat=il_err)
1164  IF (il_err.NE.0) CALL prtout &
1165  ('Error: nbnfld allocation of inipar_alloc',il_err,1)
1166  nbofld(:) = 1
1167  nbnfld(:) = 1
1168  !
1169  !* Alloc arrays needed for MOZAIC and initialize them
1170  !
1171  ALLOCATE (nmapvoi(ig_nfield),stat=il_err)
1172  IF (il_err.NE.0) CALL prtout &
1173  ('Error: nmapvoi allocation of inipar_alloc',il_err,1)
1174  ALLOCATE (nmapfl(ig_nfield),stat=il_err)
1175  IF (il_err.NE.0) CALL prtout &
1176  ('Error: nmapfl allocation of inipar_alloc',il_err,1)
1177  nmapvoi(:) = 1
1178  nmapfl(:) = 1
1179  !
1180  !* Alloc arrays needed for SUBGRID and initialize them
1181  !
1182  ALLOCATE (nsubfl(ig_nfield),stat=il_err)
1183  IF (il_err.NE.0) CALL prtout &
1184  ('Error: nsubfl allocation of inipar_alloc',il_err,1)
1185  ALLOCATE (nsubvoi(ig_nfield),stat=il_err)
1186  IF (il_err.NE.0) CALL prtout &
1187  ('Error: nsubvoi allocation of inipar_alloc',il_err,1)
1188  nsubfl(:) = 1
1189  nsubvoi(:) = 1
1190  !
1191  !* Alloc arrays needed for GLORED and REDGLO and initialize them
1192  !
1193  ALLOCATE (ntronca(ig_nfield), stat=il_err)
1194  IF (il_err.NE.0) CALL prtout &
1195  ('Error: ntronca allocation of inipar_alloc',il_err,1)
1196  ntronca(:) = 0
1197 
1198  !
1199  !* Alloc array needed for analyses parameters
1200  !
1201  ALLOCATE (cficbf(ig_nfield),stat=il_err)
1202  IF (il_err.NE.0) CALL prtout &
1203  ('Error: cficbf allocation of inipar_alloc',il_err,1)
1204  cficbf(:)=' '
1205  ALLOCATE (cficaf(ig_nfield),stat=il_err)
1206  IF (il_err.NE.0) CALL prtout &
1207  ('Error: cficaf allocation of inipar_alloc',il_err,1)
1208  cficaf(:)=' '
1209  !
1210  !* Alloc arrays needed for grid dimensions of direct fields and
1211  !* indirect fields
1212  !
1213  ALLOCATE (nlonbf(ig_nfield),stat=il_err)
1214  IF (il_err.NE.0) CALL prtout &
1215  ('Error: nlonbf allocation of inipar_alloc',il_err,1)
1216  nlonbf(:)=0
1217  ALLOCATE (nlatbf(ig_nfield),stat=il_err)
1218  IF (il_err.NE.0) CALL prtout &
1219  ('Error: nlatbf allocation of inipar_alloc',il_err,1)
1220  nlatbf(:)=0
1221  ALLOCATE (nlonaf(ig_nfield),stat=il_err)
1222  IF (il_err.NE.0) CALL prtout &
1223  ('Error: nlonaf allocation of inipar_alloc',il_err,1)
1224  nlonaf(:)=0
1225  ALLOCATE (nlataf(ig_nfield),stat=il_err)
1226  IF (il_err.NE.0) CALL prtout &
1227  ('Error: nlataf allocation of inipar_alloc',il_err,1)
1228  nlataf(:)=0
1229  !
1230  !* Alloc arrays needed for grid number associated to each field
1231 
1232  ALLOCATE (ig_grid_nbrbf(ig_nfield),stat=il_err)
1233  IF (il_err.NE.0) CALL prtout &
1234  ('Error: ig_grid_nbrbf allocation of inipar_alloc',il_err,1)
1235  ig_grid_nbrbf(:)=0
1236  ALLOCATE (ig_grid_nbraf(ig_nfield),stat=il_err)
1237  IF (il_err.NE.0) CALL prtout &
1238  ('Error: ig_grid_nbraf allocation of inipar_alloc',il_err,1)
1239  ig_grid_nbraf(:)=0
1240 
1241  !
1242  !* Alloc number of analyses array
1243  !
1244  ALLOCATE (ig_ntrans(ig_nfield),stat=il_err)
1245  IF (il_err.NE.0) CALL prtout &
1246  ('Error: ig_ntrans allocation of inipar_alloc',il_err,1)
1247  ig_ntrans(:)=0
1248  DO ib = 1, ig_final_nfield
1249  IF (lg_state(ib)) &
1250  ig_ntrans(ig_number_field(ib))=ig_total_ntrans(ib)
1251  ENDDO
1252  !
1253  !* Maximum number of analyses
1254  !
1255  il_maxanal = maxval(ig_ntrans)
1256  !
1257  !* Alloc array of restart file names
1258  !
1259  ALLOCATE (cficinp(ig_nfield), stat=il_err)
1260  IF (il_err.NE.0) CALL prtout &
1261  ('Error: cficinp allocation of inipar_alloc',il_err,1)
1262  cficinp(:)=' '
1263  DO ib = 1, ig_final_nfield
1264  IF (lg_state(ib)) &
1265  cficinp(ig_number_field(ib))=cg_restart_file(ib)
1266  END DO
1267 #ifdef use_netCDF
1268  !tcx?
1269  ! istatus=NF_OPEN(cg_restart_file(1), NF_NOWRITE, il_id)
1270  ! IF (istatus .eq. NF_NOERR) THEN
1271  ! lncdfrst = .true.
1272  ! ELSE
1273 #endif
1274  lncdfrst = .false.
1275 #ifdef use_netCDF
1276  ! ENDIF
1277  ! istatus=NF_CLOSE(il_id)
1278 #endif
1279  IF (mpi_rank_global == 0) THEN
1280  WRITE(nulprt1, *) 'lncdfrst =', lncdfrst
1281  CALL oasis_flush(nulprt1)
1282  ENDIF
1283  !
1284  !* Alloc array needed to get analysis names
1285 
1286  ALLOCATE (canal(il_maxanal,ig_nfield),stat=il_err)
1287  IF (il_err.NE.0) CALL prtout &
1288  ('Error: canal allocation of inipar_alloc',il_err,1)
1289  canal(:,:)=' '
1290  ENDIF
1291 
1292  !* Get analysis parameters
1293 
1294  rewind nulin
1295 221 CONTINUE
1296  READ (unit = nulin,fmt = 2001,END = 230) clword
1297  IF (clword .NE. clstring) go to 221
1298 
1299  !* Loop on total number of fields (NoF)
1300  !
1301  DO 250 jf=1,ig_final_nfield
1302 
1303  !* Initialization
1304 
1305  nlonbf_notnc = 0
1306  nlatbf_notnc = 0
1307  nlonaf_notnc = 0
1308  nlataf_notnc = 0
1309 
1310  !* Skip first line read before
1311 
1312  READ (unit = nulin,fmt = 2002) clline
1313  CALL skip(clline, jpeighty)
1314  !
1315  !* Second line
1316 
1317  !* In the indirect case, reading of second, third, fourth line and analyses
1318  !* lines
1319 
1320  IF (ig_total_state(jf) .NE. ip_input) THEN
1321  READ (unit = nulin,fmt = 2002) clline
1322  !* First determine what information is on the line
1323  CALL parse(clline, clvari, 3, jpeighty, ilen)
1324  IF (ilen .LT. 0) THEN
1325  !*
1326  !* IF only two words on the line, then they are the locator
1327  !* prefixes and the grids file must be in NetCDF format
1328  CALL parse(clline, clvari, 1, jpeighty, ilen)
1329  IF (lg_state(jf)) &
1330  cficbf(ig_number_field(jf)) = clvari
1331  cga_locatorbf(jf) = clvari(1:4)
1332  CALL parse(clline, clvari, 2, jpeighty, ilen)
1333  IF (lg_state(jf)) &
1334  cficaf(ig_number_field(jf)) = clvari
1335  cga_locatoraf(jf) = clvari(1:4)
1336  lncdfgrd = .true.
1337  ELSE
1338  READ(clvari,fmt = 2010) clind, clequa, iind
1339  IF (clind .EQ. 'SEQ' .OR. clind .EQ. 'LAG' .AND. &
1340  clequa .EQ. '=') THEN
1341 
1342  !* If 3rd word is an index, then first two words are
1343  !* locator prefixes and grids file must be NetCDF format
1344  CALL parse(clline, clvari, 1, jpeighty, ilen)
1345  IF (lg_state(jf)) &
1346  cficbf(ig_number_field(jf)) = clvari
1347  cga_locatorbf(jf) = clvari(1:4)
1348  CALL parse(clline, clvari, 2, jpeighty, ilen)
1349  IF (lg_state(jf)) &
1350  cficaf(ig_number_field(jf)) = clvari
1351  cga_locatoraf(jf) = clvari(1:4)
1352  lncdfgrd = .true.
1353  ELSE
1354  !* If not, the first 4 words are grid dimensions and next
1355  !* 2 words are locator prefixes, and grids file may be or
1356  !* not in NetCDF format
1357  CALL parse(clline, clvari, 1, jpeighty, ilen)
1358  !* Get number of longitudes for initial field
1359  IF (mpi_rank_global == 0) THEN
1360  WRITE(nulprt1,*)'CLVARI=',trim(clvari)
1361  CALL oasis_flush(nulprt1)
1362  ENDIF
1363  READ(clvari,fmt = 2004) nlonbf_notnc
1364  CALL parse(clline, clvari, 2, jpeighty, ilen)
1365  !* Get number of latitudes for initial field
1366  READ(clvari,fmt = 2004) nlatbf_notnc
1367  CALL parse(clline, clvari, 3, jpeighty, ilen)
1368  !* Get number of longitudes for final field
1369  READ(clvari,fmt = 2004) nlonaf_notnc
1370  CALL parse(clline, clvari, 4, jpeighty, ilen)
1371  !* Get number of latitudes for final field
1372  READ(clvari,fmt = 2004) nlataf_notnc
1373  CALL parse(clline, clvari, 5, jpeighty, ilen)
1374  !* Get root name grid-related files (initial field)
1375  IF (lg_state(jf)) &
1376  cficbf(ig_number_field(jf)) = clvari
1377  cga_locatorbf(jf) = clvari(1:4)
1378  CALL parse(clline, clvari, 6, jpeighty, ilen)
1379  !* Get root name for grid-related files (final field)
1380  IF (lg_state(jf)) &
1381  cficaf(ig_number_field(jf)) = clvari
1382  cga_locatoraf(jf) = clvari(1:4)
1383  nlonbf(ig_number_field(jf)) = nlonbf_notnc
1384  nlatbf(ig_number_field(jf)) = nlatbf_notnc
1385  nlonaf(ig_number_field(jf)) = nlonaf_notnc
1386  nlataf(ig_number_field(jf)) = nlataf_notnc
1387 
1388  ENDIF
1389  ENDIF
1390 
1391  !* Read the P 2 P 0 line for exported, expout or auxilary
1392 
1393  IF (lg_state(jf)) THEN
1394  READ (unit = nulin,fmt = 2002) clline
1395  CALL skip(clline, jpeighty)
1396  ENDIF
1397  !
1398  !* Read next line of strings
1399  ! --->>> Stuff related to field transformation
1400 
1401  IF (ig_total_ntrans(jf) .GT. 0) THEN
1402  READ (unit = nulin,fmt = 2002) clline
1403  CALL skip(clline, jpeighty)
1404  DO 260 ja = 1, ig_total_ntrans(jf)
1405  CALL parse(clline, clvari, ja, jpeighty, ilen)
1406  !* Get the whole set of analysis to be performed
1407  IF (lg_state(jf)) &
1408  canal(ja,ig_number_field(jf)) = clvari
1409 260 CONTINUE
1410  DO 270 ja = 1, ig_total_ntrans(jf)
1411  !
1412  IF (lg_state(jf)) THEN
1413  cg_c=canal(ja,ig_number_field(jf))
1414  IF (mpi_rank_global == 0) THEN
1415  WRITE(nulprt1,*)'LG_STATE cg_c=', trim(clline)
1416  CALL oasis_flush(nulprt1)
1417  ENDIF
1418  IF (cg_c .EQ. 'NOINTERP' .OR. cg_c .EQ. 'REDGLO' .OR. cg_c .EQ. 'INVERT' .OR. &
1419  cg_c .EQ. 'MASK' .OR. cg_c .EQ. 'EXTRAP' .OR. cg_c .EQ. 'CORRECT' .OR. &
1420  cg_c .EQ. 'REDGLO' .OR. cg_c .EQ. 'INTERP' .OR. cg_c .EQ. 'MOZAIC' .OR. &
1421  cg_c .EQ. 'FILLING' .OR. cg_c .EQ. 'MASKP' .OR. cg_c .EQ. 'REVERSE' .OR. &
1422  cg_c .EQ. 'GLORED') THEN
1423  IF (mpi_rank_global == 0) THEN
1424  WRITE(unit = nulprt1,fmt = *)' ***ERROR***'
1425  WRITE(unit = nulprt1,fmt = *)' OBSOLETE OPERATION= ', cg_c
1426  WRITE(unit = nulprt1,fmt = *)' SPECIFIED IN THE namcouple'
1427  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
1428  WRITE (nulprt1,'(a)') ' error = STOP in inipar'
1429  CALL oasis_flush(nulprt1)
1430  ENDIF
1431  CALL oasis_abort()
1432  ENDIF
1433  READ (unit = nulin,fmt = 2002) clline
1434  CALL skip(clline, jpeighty)
1435  IF (canal(ja,ig_number_field(jf)) .EQ. 'SCRIPR')THEN
1436  !* Get field type (scalar/vector)
1437  CALL parse(clline, clvari, 3, jpeighty, ilen)
1438  READ(clvari,fmt = 2009) clstrg
1439  ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'BLASOLD') THEN
1440  CALL parse(clline, clvari, 2, jpeighty, ilen)
1441  !* Get number of additional fields in linear formula
1442  READ(clvari,fmt = 2003) nbofld(ig_number_field(jf))
1443  DO ib = 1,nbofld(ig_number_field(jf))
1444  READ (unit = nulin,fmt = 2002) clline
1445  CALL skip(clline, jpeighty)
1446  ENDDO
1447  ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'BLASNEW') THEN
1448  CALL parse(clline, clvari, 2, jpeighty, ilen)
1449  !* Get number of additional fields in linear formula
1450  READ(clvari,fmt = 2003) nbnfld(ig_number_field(jf))
1451  DO ib = 1,nbnfld(ig_number_field(jf))
1452  READ (unit = nulin,fmt = 2002) clline
1453  CALL skip(clline, jpeighty)
1454  ENDDO
1455  ENDIF
1456  ELSE
1457  ! For IGNORED, IGNOUT and OUTPUT, only one line for LOCTRANS
1458  READ (unit = nulin,fmt = 2002) clline
1459  IF (mpi_rank_global == 0) THEN
1460  WRITE(nulprt1,*)'OUTPUT clline=', clline
1461  CALL oasis_flush(nulprt1)
1462  ENDIF
1463  CALL skip(clline, jpeighty)
1464  ENDIF
1465 270 CONTINUE
1466  !
1467  ENDIF ! IF (ig_total_ntrans(jf) .GT. 0) THEN
1468  ENDIF !IF (ig_total_state(jf) .NE. ip_input) THEN
1469  !
1470 250 CONTINUE
1471 
1472  IF (lg_oasis_field) THEN
1473  !
1474  !* Search maximum number of fields to be combined in the BLASxxx analyses
1475  !
1476  ig_maxcomb = maxval(nbofld)
1477  IF (maxval(nbnfld).GT.ig_maxcomb) &
1478  ig_maxcomb = maxval(nbnfld)
1479  !
1480  !* Search maximum number of neighbors for GAUSSIAN interpolation
1481  !
1482  ig_maxnoa = maxval(naisgvoi)
1483  IF (mpi_rank_global == 0) THEN
1484  WRITE(nulprt1,*) &
1485  'Max number of neighbors for GAUSSIAN interp : ', &
1486  ig_maxnoa
1487  WRITE(nulprt1,*)' '
1488  CALL oasis_flush(nulprt1)
1489  ENDIF
1490  !
1491  !* Search maximum number of different GAUSSIAN interpolations
1492  !
1493  ig_maxnfg = maxval(naisgfl)
1494  IF (mpi_rank_global == 0) THEN
1495  WRITE(nulprt1,*) &
1496  'Maximum number of different GAUSSIAN interpolations : ', &
1497  ig_maxnfg
1498  WRITE(nulprt1,*)' '
1499  CALL oasis_flush(nulprt1)
1500  ENDIF
1501  !
1502  ENDIF
1503  !* Formats
1504 
1505 2001 FORMAT(a9)
1506 2002 FORMAT(a5000)
1507 2003 FORMAT(i4)
1508 2004 FORMAT(i8)
1509 2009 FORMAT(a8)
1510 2010 FORMAT(a3,a1,i2)
1511 
1512  !* 3. End of routine
1513  ! --------------
1514 
1515  IF (mpi_rank_global == 0) THEN
1516  WRITE(unit = nulprt1,fmt = *)' '
1517  WRITE(unit = nulprt1,fmt = *)'-- End of ROUTINE inipar_alloc --'
1518  CALL oasis_flush(nulprt1)
1519  ENDIF
1520 
1521  ! call oasis_debug_exit(subname)
1522  RETURN
1523 
1524  !* Error branch output
1525 
1526 110 CONTINUE
1527  IF (mpi_rank_global == 0) THEN
1528  WRITE (unit = nulprt1,fmt = *) ' ***WARNING***'
1529  WRITE (unit = nulprt1,fmt = *) &
1530  ' Problem with $NBMODEL in input file namcouple'
1531  WRITE (unit = nulprt1,fmt = *) ' '
1532  WRITE (unit = nulprt1,fmt = *) ' '
1533  WRITE (unit = nulprt1,fmt = *) &
1534  ' We STOP!!! Check the file namcouple'
1535  WRITE (unit = nulprt1,fmt = *) ' '
1536  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
1537  WRITE (nulprt1,'(a)') ' error = STOP in inipar_alloc'
1538  CALL oasis_flush(nulprt1)
1539  ENDIF
1540  CALL oasis_abort()
1541 210 CONTINUE
1542  IF (mpi_rank_global == 0) THEN
1543  WRITE (unit = nulprt1,fmt = *) ' ***WARNING***'
1544  WRITE (unit = nulprt1,fmt = *) &
1545  ' No active $FIELDS data found in input file namcouple'
1546  WRITE (unit = nulprt1,fmt = *) ' '
1547  WRITE (unit = nulprt1,fmt = *) ' '
1548  WRITE (unit = nulprt1,fmt = *) &
1549  ' We STOP!!! Check the file namcouple'
1550  WRITE (unit = nulprt1,fmt = *) ' '
1551  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
1552  WRITE (nulprt1,'(a)') ' error = STOP in inipar_alloc'
1553  CALL oasis_flush(nulprt1)
1554  ENDIF
1555  CALL oasis_abort()
1556 230 CONTINUE
1557  IF (mpi_rank_global == 0) THEN
1558  WRITE (unit = nulprt1,fmt = *) ' ***WARNING***'
1559  WRITE (unit = nulprt1,fmt = *) &
1560  ' No active $STRING data found in input file namcouple'
1561  WRITE (unit = nulprt1,fmt = *) ' '
1562  WRITE (unit = nulprt1,fmt = *) ' '
1563  WRITE (unit = nulprt1,fmt = *) &
1564  ' We STOP!!! Check the file namcouple'
1565  WRITE (unit = nulprt1,fmt = *) ' '
1566  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
1567  WRITE (nulprt1,'(a)') ' error = STOP in inipar_alloc'
1568  CALL oasis_flush(nulprt1)
1569  ENDIF
1570  CALL oasis_abort()
1571 232 CONTINUE
1572  IF (mpi_rank_global == 0) THEN
1573  WRITE (unit = nulprt1,fmt = *) subname,': ***WARNING***'
1574  WRITE (unit = nulprt1,fmt = *) &
1575  ' size clline smaller than the size of the names of the fields on the line'
1576  WRITE (unit = nulprt1,fmt = *) &
1577  ' increase jpeighty and change the associated format A(jpeighty) and cline'
1578  WRITE (unit = nulprt1,fmt = *) ' '
1579  WRITE (unit = nulprt1,fmt = *) ' '
1580  WRITE (unit = nulprt1,fmt = *) &
1581  ' We STOP!!! Check the file namcouple'
1582  WRITE (unit = nulprt1,fmt = *) ' '
1583  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
1584  WRITE (nulprt1,'(a)') ' error = STOP in inipar_alloc'
1585  CALL oasis_flush(nulprt1)
1586  ENDIF
1587  CALL oasis_abort()
1588 
1589  END SUBROUTINE inipar_alloc
1590 
1591 !===============================================================================
1592 
1593  SUBROUTINE inipar
1594 !****
1595 ! *****************************
1596 ! * OASIS ROUTINE - LEVEL 0 *
1597 ! * ------------- ------- *
1598 ! *****************************
1599 
1600 !**** *inipar* - Get run parameters
1601 
1602 ! Purpose:
1603 ! -------
1604 ! Reads and prints out run parameters.
1605 
1606 !** Interface:
1607 ! ---------
1608 ! *CALL* *inipar*
1609 
1610 ! Input:
1611 ! -----
1612 ! None
1613 
1614 ! Output:
1615 ! ------
1616 ! None
1617 !
1618 ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1619 
1620  IMPLICIT NONE
1621 
1622 !* ---------------------------- Local declarations --------------------
1623 
1624  CHARACTER*5000 clline, clvari
1625  CHARACTER*9 clword, clstring, clprint, clcal, clchan
1626  CHARACTER*9 cljob, clmod, cltime, clseq, cldate, clhead
1627  CHARACTER*8 cl_print_trans, cl_print_state
1628  CHARACTER*3 clinfo, clind
1629  CHARACTER*1 clequa
1630  CHARACTER*64 cl_cfname,cl_cfunit
1631  INTEGER (kind=ip_intwp_p) iind, il_aux
1632  INTEGER (kind=ip_intwp_p) il_file_unit, id_error
1633  INTEGER (kind=ip_intwp_p) il_max_entry_id, il_no_of_entries
1634  INTEGER (kind=ip_intwp_p) il_i, il_pos
1635  LOGICAL llseq, lllag, ll_exist
1636  INTEGER lastplace
1637  integer (kind=ip_intwp_p) :: ib,ilind1,ilind2,ilind
1638  integer (kind=ip_intwp_p) :: ja,jf,jfn,jz,jm,ilen,idum
1639  integer (kind=ip_intwp_p) :: ifca,ifcb,ilab,jff,jc
1640  integer (kind=ip_intwp_p) :: icofld,imodel
1641  character(len=*),parameter :: subname='(mod_oasis_namcouple:inipar)'
1642 
1643 !* ---------------------------- Poema verses --------------------------
1644 
1645 ! call oasis_debug_enter(subname)
1646 
1647 ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1648 
1649 !* 1. Get basic info for the simulation
1650 ! ---------------------------------
1651 
1652  IF (mpi_rank_global == 0) THEN
1653  WRITE (unit = nulprt1,fmt = *)' '
1654  WRITE (unit = nulprt1,fmt = *)' ROUTINE inipar - Level 0'
1655  WRITE (unit = nulprt1,fmt = *)' ************** *******'
1656  WRITE (unit = nulprt1,fmt = *)' '
1657  WRITE (unit = nulprt1,fmt = *)' Initialization of run parameters'
1658  WRITE (unit = nulprt1,fmt = *)' Reading input file namcouple'
1659  WRITE (unit = nulprt1,fmt = *)' '
1660  CALL oasis_flush(nulprt1)
1661  ENDIF
1662 
1663 !* Initialize character keywords to locate appropriate input
1664 
1665  clstring = ' $STRINGS'
1666  cljob = ' $JOBNAME'
1667  clchan = ' $CHANNEL'
1668  clmod = ' $NBMODEL'
1669  cltime = ' $RUNTIME'
1670  clseq = ' $SEQMODE'
1671  cldate = ' $INIDATE'
1672  clhead = ' $MODINFO'
1673  clprint = ' $NLOGPRT'
1674  clcal = ' $CALTYPE'
1675 
1676  !* Initialize some variables
1677  ntime = 0 ; niter = 5
1678  nstep = 86400 ; nitfn=4
1679 
1680  !* First get experiment name
1681 
1682  rewind nulin
1683 100 CONTINUE
1684  READ (unit = nulin,fmt = 1001,END = 110) clword
1685  IF (clword .NE. cljob) go to 100
1686  IF (mpi_rank_global == 0) THEN
1687  WRITE (unit = nulprt1,fmt = *) ' ***WARNING***'
1688  WRITE (unit = nulprt1,fmt = *) 'Information below $JOBNAME'
1689  WRITE (unit = nulprt1,fmt = *) 'is obsolote in OASIS3-MCT'
1690  WRITE (unit = nulprt1,fmt = *) 'It will not be read and will not be used'
1691  CALL oasis_flush(nulprt1)
1692  ENDIF
1693 
1694 110 CONTINUE
1695 
1696  !* Get number of models involved in this simulation
1697 
1698  rewind nulin
1699 120 CONTINUE
1700  READ (unit = nulin,fmt = 1001,END = 140) clword
1701  IF (clword .NE. clmod) go to 120
1702  IF (mpi_rank_global == 0) THEN
1703  WRITE (unit = nulprt1,fmt = *) ' ***WARNING***'
1704  WRITE (unit = nulprt1,fmt = *) 'Information below $NBMODEL'
1705  WRITE (unit = nulprt1,fmt = *) 'is obsolete in OASIS3-MCT'
1706  WRITE (unit = nulprt1,fmt = *) 'It will not be read and will not be used'
1707  CALL oasis_flush(nulprt1)
1708  ENDIF
1709 
1710 140 CONTINUE
1711 
1712  !* Get hardware info for this OASIS simulation
1713 
1714  rewind nulin
1715 160 CONTINUE
1716  READ (unit = nulin,fmt = 1001,END = 170) clword
1717  IF (clword .NE. clchan) go to 160
1718  IF (mpi_rank_global == 0) THEN
1719  WRITE (unit = nulprt1,fmt = *) ' ***WARNING***'
1720  WRITE (unit = nulprt1,fmt = *) 'Information below $CHANNEL'
1721  WRITE (unit = nulprt1,fmt = *) 'is obsolote in OASIS3-MCT'
1722  WRITE (unit = nulprt1,fmt = *) 'It will not be read and will not be used'
1723  CALL oasis_flush(nulprt1)
1724  ENDIF
1725 
1726 170 CONTINUE
1727 
1728  !* Get total time for this simulation
1729 
1730  rewind nulin
1731 190 CONTINUE
1732  READ (unit = nulin,fmt = 1001,END = 191) clword
1733  IF (clword .NE. cltime) go to 190
1734  READ (unit = nulin,fmt = 1002) clline
1735  CALL parse(clline, clvari, 1, jpeighty, ilen)
1736  IF (ilen .LE. 0) THEN
1737  goto 191
1738  ELSE
1739  READ (clvari,fmt = 1004) ntime
1740  ENDIF
1741 
1742  !* Print out total time
1743 
1744  CALL prtout &
1745  ('The total time for this run is ntime =', ntime, 1)
1746 
1747  !* Get initial date for this simulation
1748 
1749  rewind nulin
1750 192 CONTINUE
1751  READ (unit = nulin,fmt = 1001,END = 193) clword
1752  IF (clword .NE. cldate) go to 192
1753  IF (mpi_rank_global == 0) THEN
1754  WRITE (unit = nulprt1,fmt = *) ' ***WARNING***'
1755  WRITE (unit = nulprt1,fmt = *) 'Information below $INIDATE'
1756  WRITE (unit = nulprt1,fmt = *) 'is obsolete in OASIS3-MCT'
1757  WRITE (unit = nulprt1,fmt = *) 'It will not be read and will not be used'
1758  CALL oasis_flush(nulprt1)
1759  ENDIF
1760 
1761 193 CONTINUE
1762 
1763  !* Get number of sequential models involved in this simulation
1764 
1765  rewind nulin
1766 194 CONTINUE
1767  READ (unit = nulin,fmt = 1001,END = 195) clword
1768  IF (clword .NE. clseq) go to 194
1769  IF (mpi_rank_global == 0) THEN
1770  WRITE (unit = nulprt1,fmt = *) ' ***WARNING***'
1771  WRITE (unit = nulprt1,fmt = *) 'Information below $SEQMODE'
1772  WRITE (unit = nulprt1,fmt = *) 'is obsolete in OASIS3-MCT'
1773  WRITE (unit = nulprt1,fmt = *) 'It will not be read and will not be used'
1774  CALL oasis_flush(nulprt1)
1775  ENDIF
1776 
1777 195 CONTINUE
1778 
1779  !* Get the information mode for this simulation
1780 
1781  rewind nulin
1782 196 CONTINUE
1783  READ (unit = nulin,fmt = 1001,END = 197) clword
1784  IF (clword .NE. clhead) go to 196
1785  IF (mpi_rank_global == 0) THEN
1786  WRITE (unit = nulprt1,fmt = *) ' ***WARNING***'
1787  WRITE (unit = nulprt1,fmt = *) 'Information below $MODINFO'
1788  WRITE (unit = nulprt1,fmt = *) 'is obsolete in OASIS3-MCT'
1789  WRITE (unit = nulprt1,fmt = *) 'It will not be read and will not be used'
1790  CALL oasis_flush(nulprt1)
1791  ENDIF
1792 
1793 197 CONTINUE
1794 
1795  !* Print out the information mode
1796 
1797  CALL prcout &
1798  ('The information mode is activated ? ==>', clinfo, 1)
1799 
1800  !* Get the printing level for this simulation
1801 
1802  rewind nulin
1803 198 CONTINUE
1804  READ (unit = nulin,fmt = 1001,END = 199) clword
1805  IF (clword .NE. clprint) go to 198
1806  nlogprt = 2
1807  READ (unit = nulin,fmt = 1002) clline
1808  CALL parse(clline, clvari, 1, jpeighty, ilen)
1809  IF (ilen .LE. 0) THEN
1810  IF (mpi_rank_global == 0) THEN
1811  WRITE (unit = nulprt1,fmt = *) ' ***WARNING***'
1812  WRITE (unit = nulprt1,fmt = *) &
1813  ' Nothing on input for $NLOGPRT '
1814  WRITE (unit = nulprt1,fmt = *) ' Default value 2 will be used '
1815  WRITE (unit = nulprt1,fmt = *) ' '
1816  CALL oasis_flush(nulprt1)
1817  ENDIF
1818  ELSE IF (ilen .gt. 8) THEN
1819  IF (mpi_rank_global == 0) THEN
1820  WRITE (unit = nulprt1,fmt = *) ' ***WARNING***'
1821  WRITE (unit = nulprt1,fmt = *) &
1822  ' Input variable length is incorrect'
1823  WRITE (unit = nulprt1,fmt = *) &
1824  ' Printing level uncorrectly specified'
1825  WRITE (unit = nulprt1,fmt = *) ' ilen = ', ilen
1826  WRITE (unit = nulprt1,fmt = *) &
1827  ' Check $NLOGPRT variable spelling '
1828  WRITE (unit = nulprt1,fmt = *) ' Default value will be used '
1829  CALL oasis_flush(nulprt1)
1830  ENDIF
1831  ELSE
1832  READ (clvari,fmt = 1004) nlogprt
1833  ENDIF
1834  ntlogprt=0
1835  CALL parse(clline, clvari, 2, jpeighty, ilen)
1836  IF (ilen > 0) THEN
1837  READ (clvari,fmt = 1004) ntlogprt
1838  ELSE
1839  IF (mpi_rank_global == 0) THEN
1840  WRITE (unit = nulprt1,fmt = *) ' ***WARNING***'
1841  WRITE (unit = nulprt1,fmt = *) &
1842  ' Nothing on input for time statistic '
1843  WRITE (unit = nulprt1,fmt = *) ' Default value 0 will be used '
1844  WRITE (unit = nulprt1,fmt = *) ' '
1845  CALL oasis_flush(nulprt1)
1846  ENDIF
1847  ENDIF
1848 
1849  !* Print out the printing level
1850 
1851  CALL prtout &
1852  ('The printing level is nlogprt =', nlogprt, 1)
1853  CALL prtout &
1854  ('The time statistics level is ntlogprt =', ntlogprt, 1)
1855 
1856  !* Get the calendar type for this simulation
1857 
1858  rewind nulin
1859 200 CONTINUE
1860  READ (unit = nulin,fmt = 1001,END = 201) clword
1861  IF (clword .NE. clcal) go to 200
1862  IF (mpi_rank_global == 0) THEN
1863  WRITE (unit = nulprt1,fmt = *) ' ***WARNING***'
1864  WRITE (unit = nulprt1,fmt = *) 'Information below $CALTYPE'
1865  WRITE (unit = nulprt1,fmt = *) 'is obsolete in OASIS3-MCT'
1866  WRITE (unit = nulprt1,fmt = *) 'It will not be read and will not be used'
1867  CALL oasis_flush(nulprt1)
1868  ENDIF
1869 
1870 201 CONTINUE
1871 
1872  !* Formats
1873 
1874 1001 FORMAT(a9)
1875 1002 FORMAT(a5000)
1876 1003 FORMAT(i3)
1877 1004 FORMAT(i8)
1878 
1879  !* 2. Get field information
1880  ! ---------------------
1881 
1882  !* Init. array needed for local transformation
1883 
1884  ig_local_trans(:) = ip_instant
1885 
1886 !SV More cleaning is needed form here on.
1887 
1888 !* Init. arrays needed for ANAIS(G-M),mapping and subgrid interpolation
1889 
1890  IF (lg_oasis_field) THEN
1891  lcoast = .true.
1892  DO 215 jz = 1, ig_nfield
1893  linit(jz) = .true.
1894  lmapp(jz) = .true.
1895  lsubg(jz) = .true.
1896  lextra(jz) = .true.
1897  varmul(jz) = 1.
1898  lsurf(jz) = .false.
1899  215 CONTINUE
1900 !
1901  ENDIF
1902 
1903 !* Get the SSCS for all fields
1904 
1905  rewind nulin
1906  220 CONTINUE
1907  READ (unit = nulin,fmt = 2001,END = 230) clword
1908  IF (clword .NE. clstring) go to 220
1909 
1910 ! Initialize restart name index
1911 
1912  il_aux = 0
1913 
1914 !* Loop on total number of fields (NoF)
1915 
1916  DO 240 jf = 1, ig_final_nfield
1917 
1918 !* Read first two lines of strings for field n = 1,2...,ig_final_nfield
1919 ! --->>> Main characteristics of fields
1920 
1921 !* First line
1922 
1923  READ (unit = nulin,fmt = 2002) clline
1924  CALL parse(clline, clvari, 1, jpeighty, ilen)
1925 !* Get output field symbolic name
1926  cg_input_field(jf) = clvari
1927  IF (lg_state(jf)) cnaminp(ig_number_field(jf)) = cg_input_field(jf)
1928  IF (lg_state(jf)) cnamout(ig_number_field(jf)) = cg_output_field(jf)
1929  CALL parse(clline, clvari, 3, jpeighty, ilen)
1930 !* Get field label number
1931  READ (clvari,fmt = 2003) ig_numlab(jf)
1932  IF (lg_state(jf)) numlab(ig_number_field(jf)) = ig_numlab(jf)
1933  CALL parse(clline, clvari, 4, jpeighty, ilen)
1934 !* Get field exchange frequency
1935  IF (clvari(1:4) .EQ. 'ONCE') THEN
1936 
1937 !* The case 'ONCE' means that the coupling period will be equal to the
1938 !* time of the simulation
1939 
1940  ig_freq(jf) = ntime
1941  ELSE
1942  READ (clvari,fmt = 2004) ig_freq(jf)
1943  IF (ig_freq(jf) .EQ. 0) THEN
1944  goto 236
1945  ELSEIF (ig_freq(jf) .gt. ntime) THEN
1946  IF (mpi_rank_global == 0) THEN
1947  WRITE (unit = nulprt1,fmt = *) ' ***WARNING***'
1948  WRITE (unit = nulprt1,fmt = *) &
1949  'The coupling period of the field ',jf
1950  WRITE (unit = nulprt1,fmt = *) &
1951  'is greater than the time of the simulation '
1952  WRITE (unit = nulprt1,fmt = *) &
1953  'This field will not be exchanged !'
1954  CALL oasis_flush(nulprt1)
1955  ENDIF
1956  ENDIF
1957  ENDIF
1958  IF (lg_state(jf)) nfexch(ig_number_field(jf)) = ig_freq(jf)
1959 !* Fill up restart file number and restart file name arrays
1960  IF (cg_restart_file(jf).ne.' ') THEN
1961  IF (jf.eq.1) THEN
1962  il_aux = il_aux + 1
1963  ig_no_rstfile(jf) = il_aux
1964  cg_name_rstfile(ig_no_rstfile(jf)) = &
1965  cg_restart_file(jf)
1966  ELSEIF (jf.gt.1) THEN
1967  IF (all(cg_name_rstfile.ne.cg_restart_file(jf))) THEN
1968  il_aux = il_aux + 1
1969  ig_no_rstfile(jf) = il_aux
1970  cg_name_rstfile(ig_no_rstfile(jf))= &
1971  cg_restart_file(jf)
1972  ELSE
1973  DO ib = 1, jf - 1
1974  IF(cg_name_rstfile(ig_no_rstfile(ib)).eq. &
1975  cg_restart_file(jf)) THEN
1976  ig_no_rstfile(jf) = ig_no_rstfile(ib)
1977  ENDIF
1978  ENDDO
1979  ENDIF
1980  ENDIF
1981  ENDIF
1982  CALL parse(clline, clvari, 7, jpeighty, ilen)
1983 !*
1984 !* Get the field STATUS
1985  IF (clvari(1:8).eq.'EXPORTED' .or. &
1986  clvari(1:8).eq.'AUXILARY') THEN
1987  cstate(ig_number_field(jf)) = clvari
1988  ELSEIF (clvari(1:6) .eq. 'EXPOUT') THEN
1989  cstate(ig_number_field(jf)) = 'EXPORTED'
1990  ENDIF
1991 !*
1992 !* Second line
1993 ! XXX Modif Graham ?
1994 
1995  IF (ig_total_state(jf) .ne. ip_input) THEN
1996  READ (unit = nulin,fmt = 2002) clline
1997 ! * First determine what information is on the line
1998  CALL parse(clline, clvari, 3, jpeighty, ilen)
1999  IF (ilen .lt. 0) THEN
2000 ! * IF only two words on the line, then they are the locator
2001 ! * prefixes and the grids file must be in NetCDF format
2002  ig_lag(jf)=0
2003  ig_total_nseqn(jf)=1
2004  IF (lg_state(jf)) then
2005  nseqn(ig_number_field(jf)) = 1
2006  nlagn(ig_number_field(jf)) = 0
2007  ENDIF
2008  llseq=.false.
2009  lllag=.false.
2010  IF (mpi_rank_global == 0) THEN
2011  WRITE (unit=nulprt1,fmt=3043) jf
2012  ENDIF
2013  ELSE
2014  READ(clvari,fmt = 2011) clind, clequa, iind
2015  IF (clind .EQ. 'SEQ' .or. clind .EQ. 'LAG' .and. &
2016  clequa .EQ. '=') THEN
2017 ! * If 3rd word is an index, then first two words are
2018 ! * locator prefixes and grids file must be NetCDF format
2019  ilind1=3
2020  ilind2=6
2021  ELSE
2022 ! * If not, the first 4 words are grid dimensions and next
2023 ! * 2 words are locator prefixes, and grids file may be or
2024 ! * not in NetCDF FORMAT.
2025  ilind1=7
2026  ilind2=10
2027  ENDIF
2028 ! * Get possibly additional indices
2029  ig_lag(jf)=0
2030  ig_total_nseqn(jf)=1
2031  IF (lg_state(jf)) then
2032  nseqn(ig_number_field(jf)) = 1
2033  nlagn(ig_number_field(jf)) = 0
2034  ENDIF
2035  llseq=.false.
2036  lllag=.false.
2037 !
2038  DO 245 ilind=ilind1, ilind2
2039  CALL parse(clline, clvari, ilind, jpeighty, ilen)
2040  IF(ilen .eq. -1) THEN
2041  IF (mpi_rank_global == 0) THEN
2042  IF (nlogprt .GE. 0) THEN
2043  IF(.NOT. lllag) WRITE (unit=nulprt1,fmt=3043) jf
2044  ENDIF
2045  ENDIF
2046  go to 247
2047  ELSE
2048  READ(clvari,fmt = 2011) clind, clequa, iind
2049  IF (clind .EQ. 'SEQ') THEN
2050  ig_total_nseqn(jf)=iind
2051  IF (lg_state(jf)) &
2052  nseqn(ig_number_field(jf)) = iind
2053  llseq=.true.
2054  ELSE IF (clind .eq. 'LAG') THEN
2055  ig_lag(jf)=iind
2056  IF (lg_state(jf)) &
2057  nlagn(ig_number_field(jf)) = iind
2058  lllag=.true.
2059  IF (mpi_rank_global == 0) THEN
2060  WRITE (unit = nulprt1,fmt = 3044)jf,ig_lag(jf)
2061  ENDIF
2062  ENDIF
2063  ENDIF
2064  245 CONTINUE
2065  ENDIF
2066  ENDIF
2067 
2068 
2069  247 CONTINUE
2070 
2071 !* Third line
2072 
2073  IF (lg_state(jf)) THEN
2074  READ (unit = nulin,fmt = 2002) clline
2075  CALL parse(clline, clvari, 1, jpeighty, ilen)
2076  ! * Get source grid periodicity type
2077  csper(ig_number_field(jf)) = clvari
2078  IF(csper(ig_number_field(jf)) .NE. 'P' .AND. &
2079  csper(ig_number_field(jf)) .NE. 'R') THEN
2080  CALL prtout &
2081  ('ERROR in namcouple for source grid type of field', jf, 1)
2082  IF (mpi_rank_global == 0) THEN
2083  WRITE (unit = nulprt1,fmt = *) '==> must be P or R'
2084  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
2085  WRITE (nulprt1,'(a)') ' error = STOP in inipar'
2086  CALL oasis_flush(nulprt1)
2087  ENDIF
2088  CALL oasis_abort()
2089  ENDIF
2090 !
2091  CALL parse(clline, clvari, 2, jpeighty, ilen)
2092 ! * Get nbr of overlapped longitudes for the Periodic type source grid
2093  READ(clvari,fmt = 2005) nosper(ig_number_field(jf))
2094  CALL parse(clline, clvari, 3, jpeighty, ilen)
2095 ! * Get target grid periodicity type
2096  ctper(ig_number_field(jf)) = clvari
2097  IF(ctper(ig_number_field(jf)) .NE. 'P' .AND. &
2098  ctper(ig_number_field(jf)) .NE. 'R') THEN
2099  CALL prtout &
2100  ('ERROR in namcouple for target grid type of field', jf, 1)
2101  IF (mpi_rank_global == 0) THEN
2102  WRITE (unit = nulprt1,fmt = *) '==> must be P or R'
2103  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
2104  WRITE (nulprt1,'(a)') ' error = STOP in inipar'
2105  CALL oasis_flush(nulprt1)
2106  ENDIF
2107  CALL oasis_abort()
2108  ENDIF
2109 !
2110  CALL parse(clline, clvari, 4, jpeighty, ilen)
2111 ! * Get nbr of overlapped longitudes for the Periodic type target grid
2112  READ(clvari,fmt = 2005) notper(ig_number_field(jf))
2113 !
2114  ENDIF
2115 
2116  !* Get the local transformation
2117 
2118  IF (.NOT. lg_state(jf)) THEN
2119  IF (ig_total_state(jf) .ne. ip_input .and. &
2120  ig_total_ntrans(jf) .gt. 0 ) THEN
2121  READ (unit = nulin,fmt = 2002) clline
2122  CALL skip(clline, jpeighty)
2123  DO ja=1,ig_total_ntrans(jf)
2124  READ (unit = nulin,fmt = 2002) clline
2125  CALL parse(clline, clvari, 1, jpeighty, ilen)
2126  IF (clvari(1:7) .eq. 'INSTANT') THEN
2127  ig_local_trans(jf) = ip_instant
2128  ELSEIF (clvari(1:7) .eq. 'AVERAGE') THEN
2129  ig_local_trans(jf) = ip_average
2130  ELSEIF (clvari(1:7) .eq. 'ACCUMUL') THEN
2131  ig_local_trans(jf) = ip_accumul
2132  ELSEIF (clvari(1:5) .eq. 'T_MIN') THEN
2133  ig_local_trans(jf) = ip_min
2134  ELSEIF (clvari(1:5) .eq. 'T_MAX') THEN
2135  ig_local_trans(jf) = ip_max
2136  ELSE
2137  CALL prtout &
2138  ('ERROR in namcouple for local transformations of field', jf, 1)
2139  IF (mpi_rank_global == 0) THEN
2140  WRITE (unit = nulprt1,fmt = *) &
2141  '==> Must be INSTANT, AVERAGE, ACCUMUL, T_MIN or T_MAX'
2142  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
2143  WRITE (nulprt1,'(a)') ' error = STOP in inipar'
2144  CALL oasis_flush(nulprt1)
2145  ENDIF
2146  CALL oasis_abort()
2147  ENDIF
2148  ENDDO
2149  ENDIF
2150  ELSE
2151  READ (unit = nulin,fmt = 2002) clline
2152  CALL skip(clline, jpeighty)
2153 !
2154 ! * Now read specifics for each transformation
2155 
2156  DO 270 ja = 1, ig_ntrans(ig_number_field(jf))
2157 !
2158 ! * Read next line unless if analysis is NOINTERP (no input)
2159 !
2160  READ (unit = nulin,fmt = 2002) clline
2161  CALL skip(clline, jpeighty)
2162  IF (canal(ja,ig_number_field(jf)) .EQ. 'LOCTRANS') THEN
2163  CALL parse(clline, clvari, 1, jpeighty, ilen)
2164  IF (clvari(1:7) .eq. 'INSTANT') THEN
2165  ig_local_trans(jf) = ip_instant
2166  ELSEIF (clvari(1:7) .eq. 'AVERAGE') THEN
2167  ig_local_trans(jf) = ip_average
2168  ELSEIF (clvari(1:7) .eq. 'ACCUMUL') THEN
2169  ig_local_trans(jf) = ip_accumul
2170  ELSEIF (clvari(1:5) .eq. 'T_MIN') THEN
2171  ig_local_trans(jf) = ip_min
2172  ELSEIF (clvari(1:5) .eq. 'T_MAX') THEN
2173  ig_local_trans(jf) = ip_max
2174  ELSE
2175  CALL prtout &
2176  ('ERROR in namcouple for local transformations of field', jf, 1)
2177  IF (mpi_rank_global == 0) THEN
2178  WRITE (unit = nulprt1,fmt = *) &
2179  '==> Must be INSTANT, AVERAGE, ACCUMUL, T_MIN or T_MAX'
2180  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
2181  WRITE (nulprt1,'(a)') ' error = STOP in inipar'
2182  CALL oasis_flush(nulprt1)
2183  ENDIF
2184  CALL oasis_abort()
2185  ENDIF
2186  ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'CHECKIN')THEN
2187  CALL parse(clline, clvari, 1, jpeighty, ilen)
2188  ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'CHECKOUT') THEN
2189  CALL parse(clline, clvari, 1, jpeighty, ilen)
2190  ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'MAPPING') THEN
2191 !* Get mapping filename
2192  CALL parse(clline, clvari, 1, jpeighty, ilen)
2193  cmap_file(ig_number_field(jf)) = trim(clvari)
2194 !* Get mapping location and/or mapping optimization; src (default), dst; bfb (default), sum, opt
2195  cmaptyp(ig_number_field(jf)) = 'src'
2196  cmapopt(ig_number_field(jf)) = 'bfb'
2197  do idum = 2,3
2198  CALL parse(clline, clvari, idum, jpeighty, ilen)
2199  if (ilen > 0) then
2200  if (trim(clvari) == 'src' .or. trim(clvari) == 'dst') then
2201  cmaptyp(ig_number_field(jf)) = trim(clvari)
2202  elseif (trim(clvari) == 'opt' .or. trim(clvari) == 'bfb' &
2203  .or. trim(clvari) == 'sum') then
2204  cmapopt(ig_number_field(jf)) = trim(clvari)
2205  else
2206  call prtout('ERROR in namcouple mapping argument',jf,1)
2207  IF (mpi_rank_global == 0) THEN
2208  WRITE(nulprt1,*) 'ERROR in namcouple mapping argument ',&
2209  trim(clvari)
2210  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
2211  WRITE (nulprt1,'(a)') ' error = STOP in inipar cmaptyp or loc'
2212  CALL oasis_flush(nulprt1)
2213  ENDIF
2214  call oasis_abort()
2215  endif
2216  endif
2217  enddo
2218  ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'SCRIPR') THEN
2219 !* Get Scrip remapping method
2220  CALL parse(clline, clvari, 1, jpeighty, ilen)
2221  READ(clvari,fmt = 2009) cmap_method(ig_number_field(jf))
2222 !* Get source grid type
2223  CALL parse(clline, clvari, 2, jpeighty, ilen)
2224  READ(clvari,fmt = 2009) cgrdtyp(ig_number_field(jf))
2225  IF (cmap_method(ig_number_field(jf)) .eq. 'BICUBIC' &
2226  .and. cgrdtyp(ig_number_field(jf)) .ne. 'LR' &
2227  .and. cgrdtyp(ig_number_field(jf)) .ne. 'D') THEN
2228  IF (mpi_rank_global == 0) THEN
2229  WRITE (unit = nulprt1,fmt = *) ' '
2230  ENDIF
2231  CALL prtout &
2232  ('ERROR in namcouple for type of field', jf, 1)
2233  IF (mpi_rank_global == 0) THEN
2234  WRITE (unit = nulprt1,fmt = *) &
2235  'BICUBIC interpolation cannot be used if grid is not LR or D'
2236  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
2237  WRITE (nulprt1,'(a)') ' error = STOP in inipar'
2238  CALL oasis_flush(nulprt1)
2239  ENDIF
2240  CALL oasis_abort()
2241  ENDIF
2242  IF (cmap_method(ig_number_field(jf)) .eq. 'BILINEAR' &
2243  .and. cgrdtyp(ig_number_field(jf)) .ne. 'LR' &
2244  .and. cgrdtyp(ig_number_field(jf)) .ne. 'D') THEN
2245  IF (mpi_rank_global == 0) THEN
2246  WRITE (unit = nulprt1,fmt = *) ' '
2247  ENDIF
2248  CALL prtout &
2249  ('ERROR in namcouple for type of field', jf, 1)
2250  IF (mpi_rank_global == 0) THEN
2251  WRITE (unit = nulprt1,fmt = *) &
2252  'BILINEAR interpolation cannot be used if grid is not LR or D'
2253  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
2254  WRITE (nulprt1,'(a)') ' error = STOP in inipar'
2255  CALL oasis_flush(nulprt1)
2256  ENDIF
2257  CALL oasis_abort()
2258  ENDIF
2259 !* Get field type (scalar/vector)
2260  CALL parse(clline, clvari, 3, jpeighty, ilen)
2261  READ(clvari,fmt = 2009) cfldtype(ig_number_field(jf))
2262  IF(cfldtype(ig_number_field(jf)) .EQ. 'VECTOR') &
2263  cfldtype(ig_number_field(jf))='SCALAR'
2264  IF(cfldtype(ig_number_field(jf)) .NE. 'SCALAR') THEN
2265  IF (mpi_rank_global == 0) THEN
2266  WRITE (unit = nulprt1,fmt = *) ' '
2267  ENDIF
2268  CALL prtout &
2269  ('ERROR in namcouple for type of field', jf, 1)
2270  IF (mpi_rank_global == 0) THEN
2271  WRITE (unit = nulprt1,fmt = *) &
2272  '==> must be SCALAR, VECTOR'
2273  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
2274  WRITE (nulprt1,'(a)') ' error = STOP in inipar'
2275  CALL oasis_flush(nulprt1)
2276  ENDIF
2277  CALL oasis_abort()
2278  ENDIF
2279 !* Get restriction type for SCRIP search
2280  CALL parse(clline, clvari, 4, jpeighty, ilen)
2281  READ(clvari,fmt = 2009) crsttype(ig_number_field(jf))
2282  IF (cgrdtyp(ig_number_field(jf)) .EQ. 'D') THEN
2283  IF (cmap_method(ig_number_field(jf)) .EQ. 'BILINEAR' .or. &
2284  cmap_method(ig_number_field(jf)) .EQ. 'BICUBIC') THEN
2285  IF (crsttype(ig_number_field(jf)) .NE. 'LATITUDE') THEN
2286  IF (mpi_rank_global == 0) THEN
2287  WRITE (unit = nulprt1,fmt = *) ' '
2288  ENDIF
2289  CALL prtout('ERROR in namcouple for restriction of field',jf,1)
2290  IF (mpi_rank_global == 0) THEN
2291  WRITE (unit = nulprt1,fmt = *) &
2292  '==> LATITUDE must be chosen for reduced grids (D)'
2293  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
2294  WRITE (nulprt1,'(a)') ' error = STOP in inipar'
2295  CALL oasis_flush(nulprt1)
2296  ENDIF
2297  CALL oasis_abort()
2298  ELSE
2299  crsttype(ig_number_field(jf)) = 'REDUCED'
2300  ENDIF
2301  ENDIF
2302  ENDIF
2303 
2304  IF(crsttype(ig_number_field(jf)) .NE. 'LATITUDE' .AND. &
2305  crsttype(ig_number_field(jf)) .NE. 'LATLON' .AND. &
2306  crsttype(ig_number_field(jf)) .NE. 'REDUCED') THEN
2307  IF (mpi_rank_global == 0) THEN
2308  WRITE (unit = nulprt1,fmt = *) ' '
2309  ENDIF
2310  CALL prtout('ERROR in namcouple for restriction of field',jf,1)
2311  IF (mpi_rank_global == 0) THEN
2312  WRITE (unit = nulprt1,fmt = *) '==> must be LATITUDE or LATLON'
2313  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
2314  WRITE (nulprt1,'(a)') ' error = STOP in inipar'
2315  CALL oasis_flush(nulprt1)
2316  ENDIF
2317  CALL oasis_abort()
2318  ENDIF
2319 !*
2320 !* Get number of search bins for SCRIP search
2321  CALL parse(clline, clvari, 5, jpeighty, ilen)
2322  READ(clvari,fmt = 2003) nbins(ig_number_field(jf))
2323 !* Get normalize option for CONSERV
2324  IF (cmap_method(ig_number_field(jf)) .EQ. 'CONSERV') THEN
2325  CALL parse(clline, clvari, 6, jpeighty, ilen)
2326  READ(clvari,fmt = 2009)cnorm_opt(ig_number_field(jf))
2327  IF (cnorm_opt(ig_number_field(jf)) .NE. 'FRACAREA' .AND. &
2328  cnorm_opt(ig_number_field(jf)) .NE. 'DESTAREA' .AND. &
2329  cnorm_opt(ig_number_field(jf)) .NE. 'FRACNNEI') THEN
2330  IF (mpi_rank_global == 0) THEN
2331  WRITE (unit = nulprt1,fmt = *) ' '
2332  ENDIF
2333  CALL prtout &
2334  ('ERROR in namcouple for normalize option of field',jf,1)
2335  IF (mpi_rank_global == 0) THEN
2336  WRITE (unit = nulprt1, fmt = *) &
2337  '==> must be FRACAREA, DESTAREA, or FRACNNEI'
2338  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
2339  WRITE (nulprt1,'(a)') ' error = STOP in inipar'
2340  CALL oasis_flush(nulprt1)
2341  ENDIF
2342  CALL oasis_abort()
2343  ENDIF
2344 !* Get order of remapping for CONSERV
2345  CALL parse(clline, clvari, 7, jpeighty, ilen)
2346  IF (ilen .LE. 0) THEN
2347  IF (mpi_rank_global == 0) THEN
2348  WRITE (unit = nulprt1,fmt = *) ' '
2349  ENDIF
2350  CALL prtout('ERROR in namcouple for CONSERV for field',jf,1)
2351  IF (mpi_rank_global == 0) THEN
2352  WRITE (unit = nulprt1,fmt = *) &
2353  '==> FIRST must be indicated at end of line'
2354  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
2355  WRITE (nulprt1,'(a)') ' error = STOP in inipar'
2356  CALL oasis_flush(nulprt1)
2357  ENDIF
2358  CALL oasis_abort()
2359  ENDIF
2360  READ(clvari,fmt = 2009) corder(ig_number_field(jf))
2361  ELSE
2362  cnorm_opt(ig_number_field(jf))='NONORM'
2363  ENDIF
2364 !* Get number of neighbours for DISTWGT and GAUSWGT
2365  IF (cmap_method(ig_number_field(jf)) .EQ. 'DISTWGT' .or. &
2366  cmap_method(ig_number_field(jf)) .EQ. 'GAUSWGT') THEN
2367  CALL parse(clline, clvari, 6, jpeighty, ilen)
2368  IF (ilen .LE. 0) THEN
2369  IF (mpi_rank_global == 0) THEN
2370  WRITE (unit = nulprt1,fmt = *) ' '
2371  ENDIF
2372  CALL prtout('ERROR in namcouple for field',jf,1)
2373  IF (mpi_rank_global == 0) THEN
2374  WRITE (unit = nulprt1,fmt = *) &
2375  '==> Number of neighbours must be indicated on the line'
2376  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
2377  WRITE (nulprt1,'(a)') ' error = STOP in inipar'
2378  CALL oasis_flush(nulprt1)
2379  ENDIF
2380  CALL oasis_abort()
2381  ELSE
2382  READ(clvari,fmt=2003)nscripvoi(ig_number_field(jf))
2383  ENDIF
2384  ENDIF
2385 !* Get gaussian variance for GAUSWGT
2386  IF (cmap_method(ig_number_field(jf)) .EQ. 'GAUSWGT') THEN
2387  CALL parse(clline, clvari, 7, jpeighty, ilen)
2388  IF (ilen .LE. 0) THEN
2389  IF (mpi_rank_global == 0) THEN
2390  WRITE (unit = nulprt1,fmt = *) ' '
2391  ENDIF
2392  CALL prtout('ERROR in namcouple for GAUSWGT for field',jf,1)
2393  IF (mpi_rank_global == 0) THEN
2394  WRITE (unit = nulprt1,fmt = *) &
2395  '==> Variance must be indicated at end of line'
2396  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
2397  WRITE (nulprt1,'(a)') ' error = STOP in inipar'
2398  CALL oasis_flush(nulprt1)
2399  ENDIF
2400  CALL oasis_abort()
2401  ELSE
2402  READ(clvari,fmt=2006) varmul(ig_number_field(jf))
2403  ENDIF
2404  ENDIF
2405 
2406  ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'FILLING') &
2407  THEN
2408  CALL parse(clline, clvari, 1, jpeighty, ilen)
2409 ! * Get data file name (used to complete the initial field array)
2410  cfilfic(ig_number_field(jf)) = clvari
2411  CALL parse(clline, clvari, 2, jpeighty, ilen)
2412 ! * Get logical unit connected to previous file
2413  READ(clvari,fmt = 2005) nlufil(ig_number_field(jf))
2414  CALL parse(clline, clvari, 3, jpeighty, ilen)
2415 ! * Get filling method
2416  cfilmet(ig_number_field(jf)) = clvari
2417 ! * If current field is SST
2418  IF(cfilmet(ig_number_field(jf))(4:6) .EQ. 'SST') THEN
2419  CALL parse(clline, clvari, 4, jpeighty, ilen)
2420 ! * Get flag for coast mismatch correction
2421  READ(clvari,fmt = 2005) nfcoast
2422  IF (cfilmet(ig_number_field(jf))(1:3) .EQ. 'SMO') &
2423  THEN
2424  CALL parse(clline, clvari, 5, jpeighty, ilen)
2425 ! * Get field name for flux corrective term
2426  cfldcor = clvari
2427  CALL parse(clline, clvari, 6, jpeighty, ilen)
2428 ! * Get logical unit used to write flux corrective term
2429  READ(clvari,fmt = 2005) nlucor
2430  ENDIF
2431  ENDIF
2432  ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'CONSERV') &
2433  THEN
2434  CALL parse(clline, clvari, 1, jpeighty, ilen)
2435 ! * Get conservation method
2436  cconmet(ig_number_field(jf)) = clvari
2437  lsurf(ig_number_field(jf)) = .true.
2438  CALL parse(clline, clvari, 2, jpeighty, ilen)
2439  cconopt(ig_number_field(jf)) = 'bfb'
2440  if (ilen > 0) then
2441  if (trim(clvari) == 'bfb' .or. trim(clvari) == 'opt') then
2442  cconopt(ig_number_field(jf)) = clvari
2443  else
2444  call prtout('ERROR in namcouple conserv argument',jf,1)
2445  IF (mpi_rank_global == 0) THEN
2446  WRITE(nulprt1,*) 'ERROR in namcouple conserv argument ',&
2447  trim(clvari)
2448  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
2449  WRITE (nulprt1,'(a)') ' error = STOP in inipar cconopt'
2450  CALL oasis_flush(nulprt1)
2451  ENDIF
2452  call oasis_abort()
2453  endif
2454  endif
2455  ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'BLASOLD')THEN
2456 ! * Get linear combination parameters for initial fields
2457  CALL parse(clline, clvari, 1, jpeighty, ilen)
2458 ! * Get main field multiplicative coefficient
2459  READ(clvari,fmt = 2006) afldcobo(ig_number_field(jf))
2460  DO 290 jc = 1, nbofld(ig_number_field(jf))
2461  READ (unit = nulin,fmt = 2002) clline
2462  CALL parse(clline, clvari, 1, jpeighty, ilen)
2463 ! * Get symbolic names for additional fields
2464  cbofld(jc,ig_number_field(jf)) = clvari
2465  CALL parse(clline, clvari, 2, jpeighty, ilen)
2466 ! * Get multiplicative coefficients for additional fields
2467  READ(clvari,fmt = 2006) &
2468  abocoef(jc,ig_number_field(jf))
2469  290 CONTINUE
2470  ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'BLASNEW')THEN
2471 ! * Get linear combination parameters for final fields
2472  CALL parse(clline, clvari, 1, jpeighty, ilen)
2473 ! * Get main field multiplicative coefficient
2474  READ(clvari,fmt = 2006) afldcobn(ig_number_field(jf))
2475  DO 291 jc = 1, nbnfld(ig_number_field(jf))
2476  READ (unit = nulin,fmt = 2002) clline
2477  CALL parse(clline, clvari, 1, jpeighty, ilen)
2478 ! * Get symbolic names for additional fields
2479  cbnfld(jc,ig_number_field(jf)) = clvari
2480  CALL parse(clline, clvari, 2, jpeighty, ilen)
2481 ! * Get multiplicative coefficients for additional fields
2482  READ(clvari,fmt = 2006) &
2483  abncoef(jc,ig_number_field(jf))
2484  291 CONTINUE
2485  ELSE
2486  IF (mpi_rank_global == 0) THEN
2487  WRITE (unit = nulprt1,fmt = *) ' ***WARNING***'
2488  WRITE (unit = nulprt1,fmt = *) &
2489  ' Type of analysis not implemented yet '
2490  WRITE (unit = nulprt1,fmt = *) &
2491  ' The analysis required in OASIS is :'
2492  WRITE (unit = nulprt1,fmt = *) ' canal = ', &
2493  canal(ja,ig_number_field(jf))
2494  WRITE (unit = nulprt1,fmt = *) &
2495  ' with ja = ', ja, ' jf = ', jf
2496  WRITE (unit = nulprt1,fmt = *) ' '
2497  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
2498  WRITE (nulprt1,'(a)') ' error = STOP in inipar'
2499  CALL oasis_flush(nulprt1)
2500  ENDIF
2501  CALL oasis_abort()
2502  ENDIF
2503  270 CONTINUE
2504  ENDIF
2505 
2506 !* End of loop on NoF
2507 
2508  240 CONTINUE
2509 
2510 !* Minimum coupling period
2511 
2512  ig_total_frqmin = minval(ig_freq)
2513 
2514 !* Formats
2515 
2516  2001 FORMAT(a9)
2517  2002 FORMAT(a5000)
2518  2003 FORMAT(i4)
2519  2004 FORMAT(i8)
2520  2005 FORMAT(i2)
2521  2006 FORMAT(e15.6)
2522  2008 FORMAT(a2,i4)
2523  2009 FORMAT(a8)
2524  2010 FORMAT(a3,a1,i2)
2525  2011 FORMAT(a3,a1,i8)
2526 
2527 !* 3. Printing
2528 ! --------
2529  IF (mpi_rank_global == 0) THEN
2530 !* Warning: no indentation for the next if (nightmare ...)
2531  IF (nlogprt .GE. 0) THEN
2532  DO 310 jf = 1, ig_final_nfield
2533  IF (ig_total_state(jf) .eq. ip_exported ) THEN
2534  cl_print_state = 'EXPORTED'
2535  ELSEIF (ig_total_state(jf) .eq. ip_ignored ) THEN
2536  cl_print_state = 'IGNORED'
2537  ELSEIF (ig_total_state(jf) .eq. ip_ignout ) THEN
2538  cl_print_state = 'IGNOUT'
2539  ELSEIF (ig_total_state(jf) .eq. ip_expout ) THEN
2540  cl_print_state = 'EXPOUT'
2541  ELSEIF (ig_total_state(jf) .eq. ip_input ) THEN
2542  cl_print_state = 'INPUT'
2543  ELSEIF (ig_total_state(jf) .eq. ip_output ) THEN
2544  cl_print_state = 'OUTPUT'
2545  ELSEIF (ig_total_state(jf) .eq. ip_auxilary ) THEN
2546  cl_print_state = 'AUXILARY'
2547  ENDIF
2548  IF (ig_local_trans(jf) .eq. ip_instant) THEN
2549  cl_print_trans = 'INSTANT'
2550  ELSEIF (ig_local_trans(jf) .eq. ip_average) THEN
2551  cl_print_trans = 'AVERAGE'
2552  ELSEIF (ig_local_trans(jf) .eq. ip_accumul) THEN
2553  cl_print_trans = 'ACCUMUL'
2554  ELSEIF (ig_local_trans(jf) .eq. ip_min) THEN
2555  cl_print_trans = 'T_MIN'
2556  ELSEIF (ig_local_trans(jf) .eq. ip_max) THEN
2557  cl_print_trans = 'T_MAX'
2558  ENDIF
2559 !* Local indexes
2560  IF (.NOT. lg_state(jf)) THEN
2561  ilab = ig_numlab(jf)
2562  WRITE (unit = nulprt1,fmt = 3001) jf
2563  WRITE (unit = nulprt1,fmt = 3002)
2564  WRITE (unit = nulprt1,fmt = 3003)
2565  WRITE (unit = nulprt1,fmt = 3004)
2566  IF (ig_total_state(jf) .eq. ip_input .or. &
2567  ig_total_state(jf) .eq. ip_output) THEN
2568  WRITE (unit = nulprt1,fmt = 3121) &
2569  cg_input_field(jf), cg_output_field(jf), &
2570  ig_freq(jf), cl_print_trans, &
2571  cl_print_state, ig_total_ntrans(jf)
2572  ELSE
2573  WRITE (unit = nulprt1,fmt = 3116) &
2574  cg_input_field(jf), cg_output_field(jf), &
2575  ig_freq(jf), cl_print_trans, ig_total_nseqn(jf), &
2576  ig_lag(jf), cl_print_state, ig_total_ntrans(jf)
2577  ENDIF
2578  ELSE
2579  ilab = numlab(ig_number_field(jf))
2580  ifcb = len_trim(cficbf(ig_number_field(jf)))
2581  ifca = len_trim(cficaf(ig_number_field(jf)))
2582  WRITE (unit = nulprt1,fmt = 3001) jf
2583  WRITE (unit = nulprt1,fmt = 3002)
2584  WRITE (unit = nulprt1,fmt = 3003)
2585  WRITE (unit = nulprt1,fmt = 3004)
2586  WRITE (unit = nulprt1,fmt = 3005) &
2587  trim(cnaminp(ig_number_field(jf))), &
2588  trim(cnamout(ig_number_field(jf))), &
2589  nfexch(ig_number_field(jf)), &
2590  nseqn(ig_number_field(jf)), &
2591  ig_lag(jf), &
2592  cl_print_state, &
2593  ig_ntrans(ig_number_field(jf))
2594  ENDIF
2595 !* Warning: no indentation for the next if (nightmare ...)
2596 !* Warning: no indentation for the next if (nightmare ...)
2597  IF (.not. lg_state(jf)) THEN
2598  IF (ig_total_state(jf) .eq. ip_ignored .or. &
2599  ig_total_state(jf) .eq. ip_ignout ) THEN
2600  WRITE (unit = nulprt1,fmt = 3117) cg_restart_file(jf)
2601  ELSEIF (ig_total_state(jf) .eq. ip_input) THEN
2602  WRITE (unit = nulprt1,fmt = 3118) cg_input_file(jf)
2603  ENDIF
2604  ELSE
2605  IF (ig_total_state(jf) .eq. ip_exported .or. &
2606  ig_total_state(jf) .eq. ip_expout .or. &
2607  ig_total_state(jf) .eq. ip_auxilary ) &
2608  WRITE (unit = nulprt1,fmt = 3117) cg_restart_file(jf)
2609 !* Warning: no indentation for the next if (nightmare ...)
2610  WRITE (unit = nulprt1,fmt = 3007) &
2611  csper(ig_number_field(jf)), nosper(ig_number_field(jf)), &
2612  ctper(ig_number_field(jf)), notper(ig_number_field(jf))
2613  WRITE (unit = nulprt1,fmt = 3008) &
2614  cficbf(ig_number_field(jf))(1:ifcb)//cglonsuf, &
2615  cficbf(ig_number_field(jf))(1:ifcb)//cglatsuf, &
2616  cficbf(ig_number_field(jf))(1:ifcb)//cmsksuf, &
2617  cficbf(ig_number_field(jf))(1:ifcb)//csursuf, &
2618  cficaf(ig_number_field(jf))(1:ifca)//cglonsuf, &
2619  cficaf(ig_number_field(jf))(1:ifca)//cglatsuf, &
2620  cficaf(ig_number_field(jf))(1:ifca)//cmsksuf, &
2621  cficaf(ig_number_field(jf))(1:ifca)//csursuf
2622  WRITE (unit = nulprt1,fmt = 3009)
2623  WRITE (unit = nulprt1,fmt = 3010)
2624  DO 320 ja = 1, ig_ntrans(ig_number_field(jf))
2625  WRITE (unit = nulprt1,fmt = 3011) ja, &
2626  canal(ja,ig_number_field(jf))
2627  IF (canal(ja,ig_number_field(jf)) .EQ. 'MAPPING') THEN
2628  write(unit = nulprt1,fmt = 3048) &
2629  trim(cmap_file(ig_number_field(jf))), &
2630  trim(cmaptyp(ig_number_field(jf))), &
2631  trim(cmapopt(ig_number_field(jf)))
2632  ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'SCRIPR') THEN
2633  WRITE(unit = nulprt1,fmt = 3045) &
2634  cmap_method(ig_number_field(jf)), &
2635  cfldtype(ig_number_field(jf)), &
2636  cnorm_opt(ig_number_field(jf)), &
2637  crsttype(ig_number_field(jf)), &
2638  nbins(ig_number_field(jf))
2639  IF (cmap_method(ig_number_field(jf)) .EQ. 'CONSERV') THEN
2640  WRITE(unit = nulprt1,fmt = 3046) &
2641  corder(ig_number_field(jf))
2642  ENDIF
2643  ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'CONSERV') THEN
2644  WRITE(unit = nulprt1,fmt = 3025) &
2645  cconmet(ig_number_field(jf)), &
2646  cconopt(ig_number_field(jf))
2647  ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'BLASOLD') THEN
2648  WRITE(unit = nulprt1,fmt = 3027) &
2649  trim(cnaminp(ig_number_field(jf))), &
2650  afldcobo(ig_number_field(jf))
2651  WRITE(unit = nulprt1,fmt=3028) nbofld(ig_number_field(jf))
2652  DO 340 jc = 1, nbofld(ig_number_field(jf))
2653  WRITE (unit = nulprt1,fmt = 3030) &
2654  cbofld(jc,ig_number_field(jf)), &
2655  abocoef(jc,ig_number_field(jf))
2656  340 CONTINUE
2657  ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'BLASNEW') THEN
2658  WRITE(unit = nulprt1,fmt = 3027) &
2659  trim(cnamout(ig_number_field(jf))), &
2660  afldcobn(ig_number_field(jf))
2661  WRITE(unit = nulprt1,fmt=3028) nbnfld(ig_number_field(jf))
2662  DO 350 jc = 1, nbnfld(ig_number_field(jf))
2663  WRITE (unit = nulprt1,fmt = 3030) &
2664  cbnfld(jc,ig_number_field(jf)), &
2665  abncoef(jc,ig_number_field(jf))
2666  350 CONTINUE
2667  ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'CHECKIN') THEN
2668  WRITE(unit = nulprt1,fmt = *) ' '
2669  ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'CHECKOUT') THEN
2670  WRITE(unit = nulprt1,fmt = *) ' '
2671  ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'LOCTRANS') THEN
2672  WRITE(unit = nulprt1,fmt = 3047) cl_print_trans
2673  ELSE
2674  WRITE (unit = nulprt1,fmt = *) ' ***WARNING***'
2675  WRITE (unit = nulprt1,fmt = *) &
2676  ' Type of analysis not implemented yet '
2677  WRITE (unit = nulprt1,fmt = *) &
2678  ' The analysis required in OASIS is :'
2679  WRITE (unit = nulprt1,fmt = *) ' canal = ', &
2680  canal(ja,ig_number_field(jf))
2681  WRITE (unit = nulprt1,fmt = *) &
2682  ' with ja = ', ja, ' jf = ', jf
2683  WRITE (unit = nulprt1,fmt = *) ' '
2684  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
2685  WRITE (nulprt1,'(a)') ' error = STOP in inipar'
2686  CALL oasis_flush(nulprt1)
2687  CALL oasis_abort()
2688  ENDIF
2689  320 CONTINUE
2690  ENDIF
2691  310 CONTINUE
2692  ENDIF
2693 ENDIF
2694 
2695 !* Formats
2696 
2697  3001 FORMAT(//,15x,' FIELD NUMBER ',i3)
2698  3002 FORMAT(15x,' ************ ')
2699  3003 FORMAT(/,10x,' Field parameters ')
2700  3004 FORMAT(10x,' **************** ',/)
2701  3005 FORMAT(/,10x,' Input field symbolic name = ',a, &
2702  /,10x,' Output field symbolic name = ',a, &
2703  /,10x,' Field exchange frequency = ',i8, &
2704  /,10x,' Model sequential index = ',i2, &
2705  /,10x,' Field Lag = ',i8, &
2706  /,10x,' Field I/O status = ',a8, &
2707  /,10x,' Number of basic operations = ',i4, /)
2708  3116 FORMAT(/,10x,' Input field symbolic name = ',a8, &
2709  /,10x,' Output field symbolic name = ',a8, &
2710  /,10x,' Field exchange frequency = ',i8, &
2711  /,10x,' Local transformation = ',a8, &
2712  /,10x,' Model sequential index = ',i2, &
2713  /,10x,' Field Lag = ',i8, &
2714  /,10x,' Field I/O status = ',a8, &
2715  /,10x,' Number of basic operations = ',i4,/)
2716  3117 FORMAT(/,10x,' Restart file name = ',a32,/)
2717  3118 FORMAT(/,10x,' Input file name = ',a32,/)
2718  3121 FORMAT(/,10x,' Input field symbolic name = ',a8, &
2719  /,10x,' Output field symbolic name = ',a8, &
2720  /,10x,' Field exchange frequency = ',i8, &
2721  /,10x,' Local transformation = ',a8, &
2722  /,10x,' Field I/O status = ',a8, &
2723  /,10x,' Number of basic operations = ',i4,/)
2724  3007 FORMAT( &
2725  /,10x,' Source grid periodicity type is = ',a8, &
2726  /,10x,' Number of overlapped grid points is = ',i2, &
2727  /,10x,' Target grid periodicity type is = ',a8, &
2728  /,10x,' Number of overlapped grid points is = ',i2,/)
2729  3008 FORMAT(/,10x,' Source longitude file string = ',a8, &
2730  /,10x,' Source latitude file string = ',a8, &
2731  /,10x,' Source mask file string = ',a8, &
2732  /,10x,' Source surface file string = ',a8, &
2733  /,10x,' Target longitude file string = ',a8, &
2734  /,10x,' Target latitude file string = ',a8, &
2735  /,10x,' Target mask file string = ',a8, &
2736  /,10x,' Target surface file string = ',a8,/)
2737  3009 FORMAT(/,10x,' ANALYSIS PARAMETERS ')
2738  3010 FORMAT(10x,' ******************* ',/)
2739  3011 FORMAT(/,5x,' ANALYSIS number ',i2,' is ',a8, &
2740  /,5x,' *************** ',/)
2741  3025 FORMAT(5x,' Conservation method for field is = ',a8, &
2742  /,5x,' Conservation option is = ',a8)
2743  3027 FORMAT(5x,' Field ',a,' is multiplied by Cst = ',e15.6)
2744  3028 FORMAT(5x,' It is combined with N fields N = ',i2)
2745  3030 FORMAT(5x,' With field ',a8,' coefficient = ',e15.6)
2746  3043 FORMAT(/,5x,'No lag in namcouple for the field', i3, &
2747  /,5x,' Default value LAG=0 will be used ')
2748  3044 FORMAT(/,5x,'The lag for the field ',i3,3x,'is : ',i8)
2749  3045 FORMAT(5x,' Remapping method is = ',a8, &
2750  /,5x,' Field type is = ',a8, &
2751  /,5x,' Normalization option is = ',a8, &
2752  /,5x,' Seach restriction type is = ',a8, &
2753  /,5x,' Number of search bins is = ',i4)
2754  3046 FORMAT(5x,' Order of remapping is = ',a8)
2755  3047 FORMAT(5x,' Local transformation = ',a8)
2756  3048 FORMAT(5x,' Remapping filename is = ',a, &
2757  /,5x,' Mapping location is = ',a8, &
2758  /,5x,' Mapping optimization is = ',a8)
2759 
2760 
2761 !* 4. End of routine
2762 ! --------------
2763 
2764  IF (mpi_rank_global == 0) THEN
2765  IF (nlogprt .GE. 0) THEN
2766  WRITE(unit = nulprt1,fmt = *)' '
2767  WRITE(unit = nulprt1,fmt = *)'------ End of ROUTINE inipar ----'
2768  CALL oasis_flush(nulprt1)
2769  ENDIF
2770  ENDIF
2771 ! call oasis_debug_exit(subname)
2772  RETURN
2773 
2774 !* Error branch output
2775 
2776  130 CONTINUE
2777  IF (mpi_rank_global == 0) THEN
2778  WRITE (unit = nulprt1,fmt = *) ' ***WARNING***'
2779  WRITE (unit = nulprt1,fmt = *) &
2780  ' No active $NBMODEL data found in input file namcouple'
2781  WRITE (unit = nulprt1,fmt = *) ' '
2782  WRITE (unit = nulprt1,fmt = *) ' '
2783  WRITE (unit = nulprt1,fmt = *) &
2784  ' We STOP!!! Check the file namcouple'
2785  WRITE (unit = nulprt1,fmt = *) ' '
2786  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
2787  WRITE (nulprt1,'(a)') ' error = STOP in inipar'
2788  CALL oasis_flush(nulprt1)
2789  ENDIF
2790  CALL oasis_abort()
2791 
2792  191 CONTINUE
2793  IF (mpi_rank_global == 0) THEN
2794  WRITE (unit = nulprt1,fmt = *) ' ***WARNING***'
2795  WRITE (unit = nulprt1,fmt = *) &
2796  ' Problem with $RUNTIME in input file namcouple'
2797  WRITE (unit = nulprt1,fmt = *) ' '
2798  WRITE (unit = nulprt1,fmt = *) ' '
2799  WRITE (unit = nulprt1,fmt = *) &
2800  ' We STOP!!! Check the file namcouple'
2801  WRITE (unit = nulprt1,fmt = *) ' '
2802  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
2803  WRITE (nulprt1,'(a)') ' error = STOP in inipar'
2804  CALL oasis_flush(nulprt1)
2805  ENDIF
2806  CALL oasis_abort()
2807  199 CONTINUE
2808  IF (mpi_rank_global == 0) THEN
2809  WRITE (unit = nulprt1,fmt = *) ' ***WARNING***'
2810  WRITE (unit = nulprt1,fmt = *) &
2811  ' No active $NLOGPRT found in input file namcouple'
2812  WRITE (unit = nulprt1,fmt = *) ' '
2813  WRITE (unit = nulprt1,fmt = *) ' '
2814  WRITE (unit = nulprt1,fmt = *) &
2815  ' We STOP!!! Check the file namcouple'
2816  WRITE (unit = nulprt1,fmt = *) ' '
2817  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
2818  WRITE (nulprt1,'(a)') ' error = STOP in inipar'
2819  CALL oasis_flush(nulprt1)
2820  ENDIF
2821  CALL oasis_abort()
2822  210 CONTINUE
2823  IF (mpi_rank_global == 0) THEN
2824  WRITE (unit = nulprt1,fmt = *) ' ***WARNING***'
2825  WRITE (unit = nulprt1,fmt = *) &
2826  ' No active $FIELDS data found in input file namcouple'
2827  WRITE (unit = nulprt1,fmt = *) ' '
2828  WRITE (unit = nulprt1,fmt = *) ' '
2829  WRITE (unit = nulprt1,fmt = *) &
2830  ' We STOP!!! Check the file namcouple'
2831  WRITE (unit = nulprt1,fmt = *) ' '
2832  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
2833  WRITE (nulprt1,'(a)') ' error = STOP in inipar'
2834  CALL oasis_flush(nulprt1)
2835  ENDIF
2836  CALL oasis_abort()
2837  230 CONTINUE
2838  IF (mpi_rank_global == 0) THEN
2839  WRITE (unit = nulprt1,fmt = *) ' ***WARNING***'
2840  WRITE (unit = nulprt1,fmt = *) &
2841  ' No active $STRING data found in input file namcouple'
2842  WRITE (unit = nulprt1,fmt = *) ' '
2843  WRITE (unit = nulprt1,fmt = *) ' '
2844  WRITE (unit = nulprt1,fmt = *) &
2845  ' We STOP!!! Check the file namcouple'
2846  WRITE (unit = nulprt1,fmt = *) ' '
2847  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
2848  WRITE (nulprt1,'(a)') ' error = STOP in inipar'
2849  CALL oasis_flush(nulprt1)
2850  ENDIF
2851  CALL oasis_abort()
2852  233 CONTINUE
2853  IF (mpi_rank_global == 0) THEN
2854  WRITE (unit = nulprt1,fmt = *) ' '
2855  ENDIF
2856  CALL prtout('ERROR in namcouple for field', jf, 1)
2857  IF (mpi_rank_global == 0) THEN
2858  WRITE (unit = nulprt1,fmt = *) &
2859  'Check the 2nd line for either the index of sequential position, &
2860  & the delay flag, or the extra timestep flag.'
2861  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
2862  WRITE (nulprt1,'(a)') ' error = STOP in inipar.f'
2863  CALL oasis_flush(nulprt1)
2864  ENDIF
2865  CALL oasis_abort()
2866  235 CONTINUE
2867  IF (mpi_rank_global == 0) THEN
2868  WRITE (unit = nulprt1,fmt = *) ' '
2869  ENDIF
2870  CALL prtout('ERROR in namcouple for field', jf, 1)
2871  IF (mpi_rank_global == 0) THEN
2872  WRITE (unit = nulprt1,fmt = *) &
2873  'An input line with integral calculation flag'
2874  WRITE (unit = nulprt1,fmt = *) &
2875  '("INT=0" or "INT=1")'
2876  WRITE (unit = nulprt1,fmt = *) &
2877  'is now required for analysis CHECKIN or CHECKOUT'
2878  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
2879  WRITE (nulprt1,'(a)') ' error = STOP in inipar.f'
2880  CALL oasis_flush(nulprt1)
2881  ENDIF
2882  CALL oasis_abort()
2883  236 CONTINUE
2884  IF (mpi_rank_global == 0) THEN
2885  WRITE (unit = nulprt1,fmt = *) ' '
2886  ENDIF
2887  CALL prtout('ERROR in namcouple for field', jf, 1)
2888  IF (mpi_rank_global == 0) THEN
2889  WRITE (unit = nulprt1,fmt = *) &
2890  'The coupling period must not be 0 !'
2891  WRITE (unit = nulprt1,fmt = *) &
2892  'If you do not want to exchange this field at all'
2893  WRITE (unit = nulprt1,fmt = *) &
2894  'give a coupling period longer than the total run time.'
2895  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
2896  WRITE (nulprt1,'(a)') ' error = STOP in inipar.f'
2897  CALL oasis_flush(nulprt1)
2898  ENDIF
2899  CALL oasis_abort()
2900 
2901  END SUBROUTINE inipar
2902 !===============================================================================
2903 
2904  SUBROUTINE alloc()
2905 
2906  IMPLICIT NONE
2907 
2908  character(len=*),parameter :: subname='(mod_oasis_namcouple:alloc)'
2909 
2910 ! call oasis_debug_enter(subname)
2911 
2912  !--- alloc_anais1
2913  ALLOCATE (varmul(ig_nfield), stat=il_err)
2914  IF (il_err.NE.0) CALL prtout('Error in "varmul"allocation of anais module',il_err,1)
2915  varmul(:)=0
2916  ALLOCATE (niwtm(ig_nfield), stat=il_err)
2917  IF (il_err.NE.0) CALL prtout('Error in "niwtm"allocation of anais module',il_err,1)
2918  niwtm(:)=0
2919  ALLOCATE (niwtg(ig_nfield), stat=il_err)
2920  IF (il_err.NE.0) CALL prtout('Error in "niwtg"allocation of anais module',il_err,1)
2921  niwtg(:)=0
2922  allocate (linit(ig_nfield), stat=il_err)
2923  if (il_err.ne.0) call prtout('error in "linit"allocation of anais module',il_err,1)
2924  linit(:)=.false.
2925 
2926  !--- alloc_analysis
2927  ALLOCATE (ncofld(ig_nfield), stat=il_err)
2928  IF (il_err.NE.0) CALL prtout('Error in "ncofld"allocation of analysis module',il_err,1)
2929  ncofld(:)=0
2930  ALLOCATE (neighborg(ig_nfield), stat=il_err)
2931  IF (il_err.NE.0) CALL prtout('Error in "neighborg"allocation of analysis module',il_err,1)
2932  neighborg(:)=0
2933  ALLOCATE (nludat(ig_maxcomb,ig_nfield), stat=il_err)
2934  IF (il_err.NE.0) CALL prtout('Error in "nludat"allocation of analysis module',il_err,1)
2935  nludat(:,:)=0
2936  ALLOCATE (nlufil(ig_nfield), stat=il_err)
2937  IF (il_err.NE.0) CALL prtout('Error in "nlufil"allocation of analysis module',il_err,1)
2938  nlufil(:)=0
2939  ALLOCATE (nlumap(ig_nfield), stat=il_err)
2940  IF (il_err.NE.0) CALL prtout('Error in "nlumap"allocation of analysis module',il_err,1)
2941  nlumap(:)=0
2942  ALLOCATE (nlusub(ig_nfield), stat=il_err)
2943  IF (il_err.NE.0) CALL prtout('Error in "nlusub"allocation of analysis module',il_err,1)
2944  nlusub(:)=0
2945  ALLOCATE (nluext(ig_nfield), stat=il_err)
2946  IF (il_err.NE.0) CALL prtout('Error in "nluext"allocation of analysis module',il_err,1)
2947  nluext(:)=0
2948  ALLOCATE (nosper(ig_nfield), stat=il_err)
2949  IF (il_err.NE.0) CALL prtout('Error in "nosper"allocation of analysis module',il_err,1)
2950  nosper(:)=0
2951  ALLOCATE (notper(ig_nfield), stat=il_err)
2952  IF (il_err.NE.0) CALL prtout('Error in "notper"allocation of analysis module',il_err,1)
2953  notper(:)=0
2954  ALLOCATE (amskval(ig_nfield), stat=il_err)
2955  IF (il_err.NE.0) CALL prtout('Error in "amskval"allocation of analysis module',il_err,1)
2956  amskval(:)=0
2957  ALLOCATE (amskvalnew(ig_nfield), stat=il_err)
2958  IF (il_err.NE.0) CALL prtout('Error in "amskvalnew"allocation of analysis module',il_err,1)
2959  amskvalnew(:)=0
2960  ALLOCATE (acocoef(ig_maxcomb,ig_nfield), stat=il_err)
2961  IF (il_err.NE.0) CALL prtout('Error in "acocoef"allocation of analysis module',il_err,1)
2962  acocoef(:,:)=0
2963  ALLOCATE (abocoef(ig_maxcomb,ig_nfield), stat=il_err)
2964  IF (il_err.NE.0) CALL prtout('Error in "abocoef"allocation of analysis module',il_err,1)
2965  abocoef(:,:)=0
2966  ALLOCATE (abncoef(ig_maxcomb,ig_nfield), stat=il_err)
2967  IF (il_err.NE.0) CALL prtout('Error in "abncoef"allocation of analysis module',il_err,1)
2968  abncoef(:,:)=0
2969  ALLOCATE (afldcoef(ig_nfield), stat=il_err)
2970  IF (il_err.NE.0) CALL prtout('Error in "afldcoef"allocation of analysis module',il_err,1)
2971  afldcoef(:)=0
2972  ALLOCATE (afldcobo(ig_nfield), stat=il_err)
2973  IF (il_err.NE.0) CALL prtout('Error in "afldcobo"allocation of analysis module',il_err,1)
2974  afldcobo(:)=0
2975  ALLOCATE (afldcobn(ig_nfield), stat=il_err)
2976  IF (il_err.NE.0) CALL prtout('Error in "afldcobn"allocation of analysis module',il_err,1)
2977  afldcobn(:)=0
2978  ALLOCATE (cxordbf(ig_nfield), stat=il_err)
2979  IF (il_err.NE.0) CALL prtout('Error in "cxordbf"allocation of analysis module',il_err,1)
2980  cxordbf(:)=' '
2981  ALLOCATE (cyordbf(ig_nfield), stat=il_err)
2982  IF (il_err.NE.0) CALL prtout('Error in "cyordbf"allocation of analysis module',il_err,1)
2983  cyordbf(:)=' '
2984  ALLOCATE (cxordaf(ig_nfield), stat=il_err)
2985  IF (il_err.NE.0) CALL prtout('Error in "cxordaf"allocation of analysis module',il_err,1)
2986  cxordaf(:)=' '
2987  ALLOCATE (cyordaf(ig_nfield), stat=il_err)
2988  IF (il_err.NE.0) CALL prtout('Error in "cyordaf"allocation of analysis module',il_err,1)
2989  cyordaf(:)=' '
2990  ALLOCATE (cgrdtyp(ig_nfield), stat=il_err)
2991  IF (il_err.NE.0) CALL prtout('Error in "cgrdtyp"allocation of analysis module',il_err,1)
2992  cgrdtyp(:)=' '
2993  ALLOCATE (cfldtyp(ig_nfield), stat=il_err)
2994  IF (il_err.NE.0) CALL prtout('Error in "cfldtyp"allocation of analysis module',il_err,1)
2995  cfldtyp(:)=' '
2996  ALLOCATE (cfilfic(ig_nfield), stat=il_err)
2997  IF (il_err.NE.0) CALL prtout('Error in "cfilfic"allocation of analysis module',il_err,1)
2998  cfilfic(:)=' '
2999  ALLOCATE (cfilmet(ig_nfield), stat=il_err)
3000  IF (il_err.NE.0) CALL prtout('Error in "cfilmet"allocation of analysis module',il_err,1)
3001  cfilmet(:)=' '
3002  ALLOCATE (cconmet(ig_nfield), stat=il_err)
3003  IF (il_err.NE.0) CALL prtout('Error in "cconmet"allocation of analysis module',il_err,1)
3004  cconmet(:)=' '
3005  ALLOCATE (cconopt(ig_nfield), stat=il_err)
3006  IF (il_err.NE.0) CALL prtout('Error in "cconopt"allocation of analysis module',il_err,1)
3007  cconopt(:)=' '
3008  ALLOCATE (cfldcoa(ig_nfield), stat=il_err)
3009  IF (il_err.NE.0) CALL prtout('Error in "cfldcoa"allocation of analysis module',il_err,1)
3010  cfldcoa(:)=' '
3011  ALLOCATE (cfldfin(ig_nfield), stat=il_err)
3012  IF (il_err.NE.0) CALL prtout('Error in "cfldfin"allocation of analysis module',il_err,1)
3013  cfldfin(:)=' '
3014  ALLOCATE (ccofld(ig_maxcomb,ig_nfield), stat=il_err)
3015  IF (il_err.NE.0) CALL prtout('Error in "ccofld"allocation of analysis module',il_err,1)
3016  ccofld(:,:)=' '
3017  ALLOCATE (cbofld(ig_maxcomb,ig_nfield), stat=il_err)
3018  IF (il_err.NE.0) CALL prtout('Error in "cbofld"allocation of analysis module',il_err,1)
3019  cbofld(:,:)=' '
3020  ALLOCATE (cbnfld(ig_maxcomb,ig_nfield), stat=il_err)
3021  IF (il_err.NE.0) CALL prtout('Error in "cbnfld"allocation of analysis module',il_err,1)
3022  cbnfld(:,:)=' '
3023  ALLOCATE (ccofic(ig_maxcomb,ig_nfield), stat=il_err)
3024  IF (il_err.NE.0) CALL prtout('Error in "ccofic"allocation of analysis module',il_err,1)
3025  ccofic(:,:)=' '
3026  ALLOCATE (cdqdt(ig_nfield), stat=il_err)
3027  IF (il_err.NE.0) CALL prtout('Error in "cdqdt"allocation of analysis module',il_err,1)
3028  cdqdt(:)=' '
3029  ALLOCATE (cgrdmap(ig_nfield), stat=il_err)
3030  IF (il_err.NE.0) CALL prtout('Error in "cgrdmap"allocation of analysis module',il_err,1)
3031  cgrdmap(:)=' '
3032  ALLOCATE (cmskrd(ig_nfield), stat=il_err)
3033  IF (il_err.NE.0) CALL prtout('Error in "cmskrd"allocation of analysis module',il_err,1)
3034  cmskrd(:)=' '
3035  ALLOCATE (cgrdsub(ig_nfield), stat=il_err)
3036  IF (il_err.NE.0) CALL prtout('Error in "cgrdsub"allocation of analysis module',il_err,1)
3037  cgrdsub(:)=' '
3038  ALLOCATE (ctypsub(ig_nfield), stat=il_err)
3039  IF (il_err.NE.0) CALL prtout('Error in "ctypsub"allocation of analysis module',il_err,1)
3040  ctypsub(:)=' '
3041  ALLOCATE (cgrdext(ig_nfield), stat=il_err)
3042  IF (il_err.NE.0) CALL prtout('Error in "cgrdext"allocation of analysis module',il_err,1)
3043  cgrdext(:)=' '
3044  ALLOCATE (csper(ig_nfield), stat=il_err)
3045  IF (il_err.NE.0) CALL prtout('Error in "csper"allocation of analysis module',il_err,1)
3046  csper(:)=' '
3047  ALLOCATE (ctper(ig_nfield), stat=il_err)
3048  IF (il_err.NE.0) CALL prtout('Error in "ctper"allocation of analysis module',il_err,1)
3049  ctper(:)=' '
3050  ALLOCATE (lsurf(ig_nfield), stat=il_err)
3051  IF (il_err.NE.0) CALL prtout('Error in "lsurf"allocation of analysis module',il_err,1)
3052  lsurf(:)=.false.
3053  ALLOCATE (nscripvoi(ig_nfield), stat=il_err)
3054  IF (il_err.NE.0) CALL prtout('Error in nscripvoi allocation of analysis module',il_err,1)
3055  nscripvoi(:)=0
3056 !
3057 !* Alloc array needed for SCRIP
3058 !
3059  ALLOCATE (cmap_method(ig_nfield),stat=il_err)
3060  IF (il_err.NE.0) CALL prtout('Error in "cmap_method" allocation of inipar_alloc',il_err,1)
3061  cmap_method(:)=' '
3062  ALLOCATE (cmap_file(ig_nfield),stat=il_err)
3063  IF (il_err.NE.0) CALL prtout('Error in "cmap_file" allocation of inipar_alloc',il_err,1)
3064  cmap_file(:)=' '
3065  ALLOCATE (cmaptyp(ig_nfield),stat=il_err)
3066  IF (il_err.NE.0) CALL prtout('Error in "cmaptyp" allocation of inipar_alloc',il_err,1)
3067  cmaptyp(:)=' '
3068  ALLOCATE (cmapopt(ig_nfield),stat=il_err)
3069  IF (il_err.NE.0) CALL prtout('Error in "cmapopt" allocation of inipar_alloc',il_err,1)
3070  cmapopt(:)=' '
3071  ALLOCATE (cfldtype(ig_nfield),stat=il_err)
3072  IF (il_err.NE.0) CALL prtout('Error in "cfldtype"allocation of inipar_alloc',il_err,1)
3073  cfldtype(:)=' '
3074  ALLOCATE (crsttype(ig_nfield),stat=il_err)
3075  IF (il_err.NE.0) CALL prtout('Error in "crsttype"allocation of inipar_alloc',il_err,1)
3076  crsttype(:)=' '
3077  ALLOCATE (nbins(ig_nfield),stat=il_err)
3078  IF (il_err.NE.0) CALL prtout('Error in "nbins"allocation of inipar_alloc',il_err,1)
3079  nbins(:)=0
3080  ALLOCATE (cnorm_opt(ig_nfield),stat=il_err)
3081  IF (il_err.NE.0) CALL prtout('Error in "cnorm_opt"allocation of inipar_alloc',il_err,1)
3082  cnorm_opt(:)=' '
3083  ALLOCATE (corder(ig_nfield),stat=il_err)
3084  IF (il_err.NE.0) CALL prtout('Error in "corder"allocation of inipar_alloc',il_err,1)
3085  corder(:)=' '
3086 !
3087  !--- alloc_extrapol1
3088  ALLOCATE (niwtn(ig_nfield), stat=il_err)
3089  IF (il_err.NE.0) CALL prtout('Error in "niwtn"allocation of extrapol module',il_err,1)
3090  niwtn(:)=0
3091  ALLOCATE (niwtng(ig_nfield), stat=il_err)
3092  IF (il_err.NE.0) CALL prtout('Error in "niwtng"allocation of extrapol module',il_err,1)
3093  niwtng(:)=0
3094  ALLOCATE (lextra(ig_nfield), stat=il_err)
3095  IF (il_err.NE.0) CALL prtout('Error in "lextra"allocation of extrapol module',il_err,1)
3096  lextra(:)=.false.
3097  ALLOCATE (lweight(ig_nfield), stat=il_err)
3098  IF (il_err.NE.0) CALL prtout('Error in "lweight"allocation of extrapol module',il_err,1)
3099  lweight(:)=.false.
3100 
3101  !--- alloc_rainbow1
3102  ALLOCATE (lmapp(ig_nfield), stat=il_err)
3103  IF (il_err.NE.0) CALL prtout('Error in "lmapp"allocation of rainbow module',il_err,1)
3104  lmapp(:)=.false.
3105  ALLOCATE (lsubg(ig_nfield), stat=il_err)
3106  IF (il_err.NE.0) CALL prtout('Error in "lsubg"allocation of rainbow module',il_err,1)
3107  lsubg(:)=.false.
3108 
3109  !--- alloc_string
3110  ALLOCATE (cg_name_rstfile(ig_nbr_rstfile), stat=il_err)
3111  IF (il_err.NE.0) CALL prtout('Error in "cg_name_rstfile"allocation of string module',il_err,1)
3112  cg_name_rstfile(:)=' '
3113  ALLOCATE (ig_lag(ig_total_nfield), stat=il_err)
3114  IF (il_err.NE.0) CALL prtout('Error in "ig_lag"allocation of string module',il_err,1)
3115  ig_lag(:)=0
3116  ALLOCATE (ig_no_rstfile(ig_total_nfield), stat=il_err)
3117  IF (il_err.NE.0) CALL prtout('Error in "ig_no_rstfile"allocation of string module',il_err,1)
3118  ig_no_rstfile(:)=1
3119  ALLOCATE (cg_input_field(ig_total_nfield), stat=il_err)
3120  IF (il_err.NE.0) CALL prtout('Error in "cg_input_field"allocation of string module',il_err,1)
3121  cg_input_field(:)=' '
3122  ALLOCATE (ig_numlab(ig_total_nfield), stat=il_err)
3123  IF (il_err.NE.0) CALL prtout('Error in "ig_numlab"allocation of string module',il_err,1)
3124  ig_numlab(:)=0
3125  ALLOCATE (ig_freq(ig_total_nfield), stat=il_err)
3126  IF (il_err.NE.0) CALL prtout('Error in "ig_freq"allocation of string module',il_err,1)
3127  ig_freq(:)=0
3128  ALLOCATE (ig_total_nseqn(ig_total_nfield), stat=il_err)
3129  IF (il_err.NE.0) CALL prtout('Error in "ig_total_nseqn"allocation of string module',il_err,1)
3130  ig_total_nseqn(:)=0
3131  ALLOCATE (ig_local_trans(ig_total_nfield), stat=il_err)
3132  IF (il_err.NE.0) CALL prtout('Error in "ig_local_trans"allocation of string module',il_err,1)
3133  ig_local_trans(:)=0
3134  ALLOCATE (ig_invert(ig_total_nfield), stat=il_err)
3135  IF (il_err.NE.0) CALL prtout('Error in "ig_invert" allocation of string module',il_err,1)
3136  ig_invert(:)=0
3137  ALLOCATE (ig_reverse(ig_total_nfield), stat=il_err)
3138  IF (il_err.NE.0) CALL prtout('Error in "ig_reverse" allocation of string module',il_err,1)
3139  ig_reverse(:)=0
3140 !
3141 !** + Allocate following arrays only if one field (at least) goes
3142 ! through Oasis
3143 !
3144  IF (lg_oasis_field) THEN
3145  ALLOCATE (numlab(ig_nfield), stat=il_err)
3146  IF (il_err.NE.0) CALL prtout('Error in "numlab"allocation of string module',il_err,1)
3147  numlab(:)=0
3148  ALLOCATE (nfexch(ig_nfield), stat=il_err)
3149  IF (il_err.NE.0) CALL prtout('Error in "nfexch"allocation of string module',il_err,1)
3150  nfexch(:)=0
3151  ALLOCATE (nseqn(ig_nfield), stat=il_err)
3152  IF (il_err.NE.0) CALL prtout('Error in "nseqn"allocation of string module',il_err,1)
3153  nseqn(:)=0
3154  ALLOCATE (nlagn(ig_nfield), stat=il_err)
3155  IF (il_err.NE.0) CALL prtout('Error in "nlagn" allocation of string module',il_err,1)
3156  nlagn(:)=0
3157  ALLOCATE (cnaminp(ig_nfield), stat=il_err)
3158  IF (il_err.NE.0) CALL prtout('Error in "cnaminp"allocation of string module',il_err,1)
3159  cnaminp(:)=' '
3160  ALLOCATE (cnamout(ig_nfield), stat=il_err)
3161  IF (il_err.NE.0) CALL prtout('Error in "cnamout"allocation of string module',il_err,1)
3162  cnamout(:)=' '
3163  ALLOCATE (cficout(ig_nfield), stat=il_err)
3164  IF (il_err.NE.0) CALL prtout('Error in "cficout"allocation of string module',il_err,1)
3165  cficout(:)=' '
3166  ALLOCATE (cstate(ig_nfield), stat=il_err)
3167  IF (il_err.NE.0) CALL prtout('Error in "cstate"allocation of string module',il_err,1)
3168  cstate(:)=' '
3169  ENDIF
3170 
3171 ! call oasis_debug_exit(subname)
3172 
3173  END SUBROUTINE alloc
3174 !===============================================================================
3175  SUBROUTINE dealloc
3176 
3177  IMPLICIT NONE
3178 
3179  character(len=*),parameter :: subname='(mod_oasis_namcouple:dealloc)'
3180 
3181  !--- alloc_anais1
3182  DEALLOCATE (varmul, stat=il_err)
3183  IF (il_err.NE.0) CALL prtout('Error in "varmul"deallocation of anais module',il_err,1)
3184  DEALLOCATE (niwtm, stat=il_err)
3185  IF (il_err.NE.0) CALL prtout('Error in "niwtm"deallocation of anais module',il_err,1)
3186  DEALLOCATE (niwtg, stat=il_err)
3187  IF (il_err.NE.0) CALL prtout('Error in "niwtg"deallocation of anais module',il_err,1)
3188  deallocate (linit, stat=il_err)
3189  if (il_err.ne.0) call prtout('error in "linit"deallocation of anais module',il_err,1)
3190 
3191  !--- alloc_analysis
3192  DEALLOCATE (ncofld, stat=il_err)
3193  IF (il_err.NE.0) CALL prtout('Error in "ncofld"deallocation of analysis module',il_err,1)
3194  DEALLOCATE (neighborg, stat=il_err)
3195  IF (il_err.NE.0) CALL prtout('Error in "neighborg"deallocation of analysis module',il_err,1)
3196  DEALLOCATE (nludat, stat=il_err)
3197  IF (il_err.NE.0) CALL prtout('Error in "nludat"deallocation of analysis module',il_err,1)
3198  DEALLOCATE (nlufil, stat=il_err)
3199  IF (il_err.NE.0) CALL prtout('Error in "nlufil"deallocation of analysis module',il_err,1)
3200  DEALLOCATE (nlumap, stat=il_err)
3201  IF (il_err.NE.0) CALL prtout('Error in "nlumap"deallocation of analysis module',il_err,1)
3202  DEALLOCATE (nlusub, stat=il_err)
3203  IF (il_err.NE.0) CALL prtout('Error in "nlusub"deallocation of analysis module',il_err,1)
3204  DEALLOCATE (nluext, stat=il_err)
3205  IF (il_err.NE.0) CALL prtout('Error in "nluext"deallocation of analysis module',il_err,1)
3206  DEALLOCATE (nosper, stat=il_err)
3207  IF (il_err.NE.0) CALL prtout('Error in "nosper"deallocation of analysis module',il_err,1)
3208  DEALLOCATE (notper, stat=il_err)
3209  IF (il_err.NE.0) CALL prtout('Error in "notper"deallocation of analysis module',il_err,1)
3210  DEALLOCATE (amskval, stat=il_err)
3211  IF (il_err.NE.0) CALL prtout('Error in "amskval"deallocation of analysis module',il_err,1)
3212  DEALLOCATE (amskvalnew, stat=il_err)
3213  IF (il_err.NE.0) CALL prtout('Error in "amskvalnew"deallocation of analysis module',il_err,1)
3214  DEALLOCATE (acocoef, stat=il_err)
3215  IF (il_err.NE.0) CALL prtout('Error in "acocoef"deallocation of analysis module',il_err,1)
3216  DEALLOCATE (abocoef, stat=il_err)
3217  IF (il_err.NE.0) CALL prtout('Error in "abocoef"deallocation of analysis module',il_err,1)
3218  DEALLOCATE (abncoef, stat=il_err)
3219  IF (il_err.NE.0) CALL prtout('Error in "abncoef"deallocation of analysis module',il_err,1)
3220  DEALLOCATE (afldcoef, stat=il_err)
3221  IF (il_err.NE.0) CALL prtout('Error in "afldcoef"deallocation of analysis module',il_err,1)
3222  DEALLOCATE (afldcobo, stat=il_err)
3223  IF (il_err.NE.0) CALL prtout('Error in "afldcobo"deallocation of analysis module',il_err,1)
3224  DEALLOCATE (afldcobn, stat=il_err)
3225  IF (il_err.NE.0) CALL prtout('Error in "afldcobn"deallocation of analysis module',il_err,1)
3226  DEALLOCATE (cxordbf, stat=il_err)
3227  IF (il_err.NE.0) CALL prtout('Error in "cxordbf"deallocation of analysis module',il_err,1)
3228  DEALLOCATE (cyordbf, stat=il_err)
3229  IF (il_err.NE.0) CALL prtout('Error in "cyordbf"deallocation of analysis module',il_err,1)
3230  DEALLOCATE (cxordaf, stat=il_err)
3231  IF (il_err.NE.0) CALL prtout('Error in "cxordaf"deallocation of analysis module',il_err,1)
3232  DEALLOCATE (cyordaf, stat=il_err)
3233  IF (il_err.NE.0) CALL prtout('Error in "cyordaf"deallocation of analysis module',il_err,1)
3234  DEALLOCATE (cgrdtyp, stat=il_err)
3235  IF (il_err.NE.0) CALL prtout('Error in "cgrdtyp"deallocation of analysis module',il_err,1)
3236  DEALLOCATE (cfldtyp, stat=il_err)
3237  IF (il_err.NE.0) CALL prtout('Error in "cfldtyp"deallocation of analysis module',il_err,1)
3238  DEALLOCATE (cfilfic, stat=il_err)
3239  IF (il_err.NE.0) CALL prtout('Error in "cfilfic"deallocation of analysis module',il_err,1)
3240  DEALLOCATE (cfilmet, stat=il_err)
3241  IF (il_err.NE.0) CALL prtout('Error in "cfilmet"deallocation of analysis module',il_err,1)
3242  DEALLOCATE (cconmet, stat=il_err)
3243  IF (il_err.NE.0) CALL prtout('Error in "cconmet"deallocation of analysis module',il_err,1)
3244  DEALLOCATE (cconopt, stat=il_err)
3245  IF (il_err.NE.0) CALL prtout('Error in "cconopt"deallocation of analysis module',il_err,1)
3246  DEALLOCATE (cfldcoa, stat=il_err)
3247  IF (il_err.NE.0) CALL prtout('Error in "cfldcoa"deallocation of analysis module',il_err,1)
3248  DEALLOCATE (cfldfin, stat=il_err)
3249  IF (il_err.NE.0) CALL prtout('Error in "cfldfin"deallocation of analysis module',il_err,1)
3250  DEALLOCATE (ccofld, stat=il_err)
3251  IF (il_err.NE.0) CALL prtout('Error in "ccofld"deallocation of analysis module',il_err,1)
3252  DEALLOCATE (cbofld, stat=il_err)
3253  IF (il_err.NE.0) CALL prtout('Error in "cbofld"deallocation of analysis module',il_err,1)
3254  DEALLOCATE (cbnfld, stat=il_err)
3255  IF (il_err.NE.0) CALL prtout('Error in "cbnfld"deallocation of analysis module',il_err,1)
3256  DEALLOCATE (ccofic, stat=il_err)
3257  IF (il_err.NE.0) CALL prtout('Error in "ccofic"deallocation of analysis module',il_err,1)
3258  DEALLOCATE (cdqdt, stat=il_err)
3259  IF (il_err.NE.0) CALL prtout('Error in "cdqdt"deallocation of analysis module',il_err,1)
3260  DEALLOCATE (cgrdmap, stat=il_err)
3261  IF (il_err.NE.0) CALL prtout('Error in "cgrdmap"deallocation of analysis module',il_err,1)
3262  DEALLOCATE (cmskrd, stat=il_err)
3263  IF (il_err.NE.0) CALL prtout('Error in "cmskrd"deallocation of analysis module',il_err,1)
3264  DEALLOCATE (cgrdsub, stat=il_err)
3265  IF (il_err.NE.0) CALL prtout('Error in "cgrdsub"deallocation of analysis module',il_err,1)
3266  DEALLOCATE (ctypsub, stat=il_err)
3267  IF (il_err.NE.0) CALL prtout('Error in "ctypsub"deallocation of analysis module',il_err,1)
3268  DEALLOCATE (cgrdext, stat=il_err)
3269  IF (il_err.NE.0) CALL prtout('Error in "cgrdext"deallocation of analysis module',il_err,1)
3270  DEALLOCATE (csper, stat=il_err)
3271  IF (il_err.NE.0) CALL prtout('Error in "csper"deallocation of analysis module',il_err,1)
3272  DEALLOCATE (ctper, stat=il_err)
3273  IF (il_err.NE.0) CALL prtout('Error in "ctper"deallocation of analysis module',il_err,1)
3274  DEALLOCATE (lsurf, stat=il_err)
3275  IF (il_err.NE.0) CALL prtout('Error in "lsurf"deallocation of analysis module',il_err,1)
3276  DEALLOCATE (nscripvoi, stat=il_err)
3277  IF (il_err.NE.0) CALL prtout('Error in nscripvoi deallocation of analysis module',il_err,1)
3278 !
3279 !* Alloc array needed for SCRIP
3280 !
3281  DEALLOCATE (cmap_method,stat=il_err)
3282  IF (il_err.NE.0) CALL prtout('Error in "cmap_method" deallocation of inipar_alloc',il_err,1)
3283  DEALLOCATE (cmap_file,stat=il_err)
3284  IF (il_err.NE.0) CALL prtout('Error in "cmap_file" deallocation of inipar_alloc',il_err,1)
3285  DEALLOCATE (cmaptyp,stat=il_err)
3286  IF (il_err.NE.0) CALL prtout('Error in "cmaptyp" deallocation of inipar_alloc',il_err,1)
3287  DEALLOCATE (cmapopt,stat=il_err)
3288  IF (il_err.NE.0) CALL prtout('Error in "cmapopt" deallocation of inipar_alloc',il_err,1)
3289  DEALLOCATE (cfldtype,stat=il_err)
3290  IF (il_err.NE.0) CALL prtout('Error in "cfldtype"deallocation of inipar_alloc',il_err,1)
3291  DEALLOCATE (crsttype,stat=il_err)
3292  IF (il_err.NE.0) CALL prtout('Error in "crsttype"deallocation of inipar_alloc',il_err,1)
3293  DEALLOCATE (nbins,stat=il_err)
3294  IF (il_err.NE.0) CALL prtout('Error in "nbins"deallocation of inipar_alloc',il_err,1)
3295  DEALLOCATE (cnorm_opt,stat=il_err)
3296  IF (il_err.NE.0) CALL prtout('Error in "cnorm_opt"deallocation of inipar_alloc',il_err,1)
3297  DEALLOCATE (corder,stat=il_err)
3298  IF (il_err.NE.0) CALL prtout('Error in "corder"deallocation of inipar_alloc',il_err,1)
3299  !
3300  !--- alloc_extrapol1
3301  DEALLOCATE (niwtn, stat=il_err)
3302  IF (il_err.NE.0) CALL prtout('Error in "niwtn"deallocation of extrapol module',il_err,1)
3303  DEALLOCATE (niwtng, stat=il_err)
3304  IF (il_err.NE.0) CALL prtout('Error in "niwtng"deallocation of extrapol module',il_err,1)
3305  DEALLOCATE (lextra, stat=il_err)
3306  IF (il_err.NE.0) CALL prtout('Error in "lextra"deallocation of extrapol module',il_err,1)
3307  DEALLOCATE (lweight, stat=il_err)
3308  IF (il_err.NE.0) CALL prtout('Error in "lweight"deallocation of extrapol module',il_err,1)
3309 
3310  !--- alloc_rainbow1
3311  DEALLOCATE (lmapp, stat=il_err)
3312  IF (il_err.NE.0) CALL prtout('Error in "lmapp"deallocation of rainbow module',il_err,1)
3313  DEALLOCATE (lsubg, stat=il_err)
3314  IF (il_err.NE.0) CALL prtout('Error in "lsubg"deallocation of rainbow module',il_err,1)
3315 
3316  !--- alloc_string
3317  DEALLOCATE (cg_name_rstfile, stat=il_err)
3318  IF (il_err.NE.0) CALL prtout('Error in "cg_name_rstfile"deallocation of string module',il_err,1)
3319  DEALLOCATE (ig_lag, stat=il_err)
3320  IF (il_err.NE.0) CALL prtout('Error in "ig_lag"deallocation of string module',il_err,1)
3321  DEALLOCATE (ig_no_rstfile, stat=il_err)
3322  IF (il_err.NE.0) CALL prtout('Error in "ig_no_rstfile"deallocation of string module',il_err,1)
3323  DEALLOCATE (cg_input_field, stat=il_err)
3324  IF (il_err.NE.0) CALL prtout('Error in "cg_input_field"deallocation of string module',il_err,1)
3325  DEALLOCATE (ig_numlab, stat=il_err)
3326  IF (il_err.NE.0) CALL prtout('Error in "ig_numlab"deallocation of string module',il_err,1)
3327  DEALLOCATE (ig_freq, stat=il_err)
3328  IF (il_err.NE.0) CALL prtout('Error in "ig_freq"deallocation of string module',il_err,1)
3329  DEALLOCATE (ig_total_nseqn, stat=il_err)
3330  IF (il_err.NE.0) CALL prtout('Error in "ig_total_nseqn"deallocation of string module',il_err,1)
3331  DEALLOCATE (ig_local_trans, stat=il_err)
3332  IF (il_err.NE.0) CALL prtout('Error in "ig_local_trans"deallocation of string module',il_err,1)
3333  DEALLOCATE (ig_invert, stat=il_err)
3334  IF (il_err.NE.0) CALL prtout('Error in "ig_invert" deallocation of string module',il_err,1)
3335  DEALLOCATE (ig_reverse, stat=il_err)
3336  IF (il_err.NE.0) CALL prtout('Error in "ig_reverse" deallocation of string module',il_err,1)
3337 !
3338 !** + Deallocate following arrays only if one field (at least) goes
3339 ! through Oasis
3340 !
3341  IF (lg_oasis_field) THEN
3342  DEALLOCATE (numlab, stat=il_err)
3343  IF (il_err.NE.0) CALL prtout('Error in "numlab"deallocation of string module',il_err,1)
3344  DEALLOCATE (nfexch, stat=il_err)
3345  IF (il_err.NE.0) CALL prtout('Error in "nfexch"deallocation of string module',il_err,1)
3346  DEALLOCATE (nseqn, stat=il_err)
3347  IF (il_err.NE.0) CALL prtout('Error in "nseqn"deallocation of string module',il_err,1)
3348  DEALLOCATE (nlagn, stat=il_err)
3349  IF (il_err.NE.0) CALL prtout('Error in "nlagn" deallocation of string module',il_err,1)
3350  DEALLOCATE (cnaminp, stat=il_err)
3351  IF (il_err.NE.0) CALL prtout('Error in "cnaminp"deallocation of string module',il_err,1)
3352  DEALLOCATE (cnamout, stat=il_err)
3353  IF (il_err.NE.0) CALL prtout('Error in "cnamout"deallocation of string module',il_err,1)
3354  DEALLOCATE (cficout, stat=il_err)
3355  IF (il_err.NE.0) CALL prtout('Error in "cficout"deallocation of string module',il_err,1)
3356  DEALLOCATE (cstate, stat=il_err)
3357  IF (il_err.NE.0) CALL prtout('Error in "cstate"deallocation of string module',il_err,1)
3358  ENDIF
3359 
3360 ! call oasis_debug_exit(subname)
3361 
3362  END SUBROUTINE dealloc
3363 !===============================================================================
3364 
3365  SUBROUTINE prtout(cdtext, kvalue, kstyle)
3366 
3367 !****
3368 ! *****************************
3369 ! * OASIS ROUTINE - LEVEL 1 *
3370 ! * ------------- ------- *
3371 ! *****************************
3372 !
3373 !**** *prtout* - Print output
3374 !
3375 ! Purpose:
3376 ! -------
3377 ! Print out character string and one integer value
3378 !
3379 !** Interface:
3380 ! ---------
3381 ! *CALL* *prtout (cdtext, kvalue, kstyle)*
3382 !
3383 ! Input:
3384 ! -----
3385 ! cdtext : character string to be printed
3386 ! kvalue : integer variable to be printed
3387 ! kstyle : printing style
3388 !
3389 ! Output:
3390 ! ------
3391 ! None
3392 !
3393 ! Workspace:
3394 ! ---------
3395 !
3396 ! Externals:
3397 ! ---------
3398 ! None
3399 !
3400 ! Reference:
3401 ! ---------
3402 ! See OASIS manual (1995)
3403 !
3404 ! History:
3405 ! -------
3406 ! Version Programmer Date Description
3407 ! ------- ---------- ---- -----------
3408 ! 2.0 L. Terray 95/10/01 created
3409 ! 2.3 L. Terray 99/02/24 modified: X format for NEC
3410 !
3411 ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3412 
3413  IMPLICIT NONE
3414 !
3415 !* ---------------------------- Include files ---------------------------
3416 !
3417 !
3418 !* ---------------------------- Argument declarations ----------------------
3419 !
3420  CHARACTER(len=*),intent(in) :: cdtext
3421  INTEGER (kind=ip_intwp_p),intent(in) :: kvalue, kstyle
3422 
3423 !* ---------------------------- Local declarations ----------------------
3424 
3425  integer(kind=ip_intwp_p) :: ilen,jl
3426  CHARACTER*69 cline
3427  character(len=*),PARAMETER :: cbase = '-'
3428  character(len=*),PARAMETER :: cprpt = '* ===>>> :'
3429  character(len=*),PARAMETER :: cdots = ' ------ '
3430  character(len=*),parameter :: subname='(mod_oasis_namcouple:prtout)'
3431 
3432 !* ---------------------------- Poema verses ----------------------------
3433 
3434 ! call oasis_debug_enter(subname)
3435 
3436 ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3437 
3438 !* 1. Print character string + integer value
3439 ! --------------------------------------
3440 
3441  IF (mpi_rank_global == 0) THEN
3442  IF ( kstyle .EQ. 1 .OR. kstyle .EQ. 2) THEN
3443  cline = ' '
3444  ilen = len(cdtext)
3445  DO 110 jl = 1, ilen
3446  cline(jl:jl) = cbase
3447  110 CONTINUE
3448 
3449  IF ( kstyle .EQ. 2 ) THEN
3450  WRITE(unit = nulprt1,fmt='(/,A,1X,A)') cdots, cline
3451  ENDIF
3452  WRITE(unit = nulprt1,fmt='(A,1X,A,1X,I18)') cprpt, cdtext, kvalue
3453  WRITE(unit = nulprt1,fmt='(A,1X,A,/)') cdots, cline
3454  ELSE
3455  WRITE(unit = nulprt1,fmt='(/,A,1X,A,1X,I18,/)') cprpt, cdtext, kvalue
3456  ENDIF
3457 
3458 !* 2. End of routine
3459 ! --------------
3460 
3461  CALL oasis_flush(nulprt1)
3462  ENDIF
3463 
3464 ! call oasis_debug_exit(subname)
3465 
3466  END SUBROUTINE prtout
3467 
3468 !===============================================================================
3469 
3470  SUBROUTINE prcout (cdtext, cdstring, kstyle)
3471 !****
3472 ! *****************************
3473 ! * OASIS ROUTINE - LEVEL 1 *
3474 ! * ------------- ------- *
3475 ! *****************************
3476 !
3477 !**** *prcout* - Print output
3478 !
3479 ! Purpose:
3480 ! -------
3481 ! Print out character string and one character value
3482 !
3483 !** Interface:
3484 ! ---------
3485 ! *CALL* *prcout (cdtext, cdstring, kstyle)*
3486 !
3487 ! Input:
3488 ! -----
3489 ! cdtext : character string to be printed
3490 ! cdstring : character variable to be printed
3491 ! kstyle : printing style
3492 !
3493 ! Output:
3494 ! ------
3495 ! None
3496 !
3497 ! Workspace:
3498 ! ---------
3499 ! None
3500 !
3501 ! Externals:
3502 ! ---------
3503 ! None
3504 !
3505 ! Reference:
3506 ! ---------
3507 ! See OASIS manual (1995)
3508 !
3509 ! History:
3510 ! -------
3511 ! Version Programmer Date Description
3512 ! ------- ---------- ---- -----------
3513 ! 2.0 L. Terray 95/10/01 created
3514 ! 2.3 L. Terray 99/02/24 modified: X format for NEC
3515 !
3516 ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3517 !
3518  IMPLICIT NONE
3519 !
3520 !* ---------------------------- Include files ---------------------------
3521 !
3522 !
3523 !* ---------------------------- Argument declarations ----------------------
3524 !
3525  CHARACTER(len=*),intent(in) :: cdtext, cdstring
3526  INTEGER (kind=ip_intwp_p),intent(in) :: kstyle
3527 !
3528 !* ---------------------------- Local declarations ----------------------
3529 !
3530  integer (kind=ip_intwp_p) :: ilen,jl
3531  CHARACTER*69 cline
3532  character(len=*), PARAMETER :: cpbase = '-'
3533  character(len=*), PARAMETER :: cprpt = '* ===>>> :'
3534  character(len=*), PARAMETER :: cpdots = ' ------ '
3535  character(len=*),parameter :: subname='(mod_oasis_namcouple:prcout)'
3536 !
3537 !* ---------------------------- Poema verses ----------------------------
3538 !
3539 ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3540 !
3541 !* 1. Print character string + character value
3542 ! ----------------------------------------
3543 !
3544 ! call oasis_debug_enter(subname)
3545 
3546  IF (mpi_rank_global == 0) THEN
3547  IF ( kstyle .EQ. 1 .OR. kstyle .EQ. 2) THEN
3548  cline = ' '
3549  ilen = len(cdtext)
3550  DO 110 jl = 1, ilen
3551  cline(jl:jl) = cpbase
3552  110 CONTINUE
3553  IF ( kstyle .EQ. 2 ) THEN
3554  WRITE(unit = nulprt1,fmt='(/,A,1X,A)') cpdots, cline
3555  ENDIF
3556  WRITE(unit = nulprt1,fmt='(A,1X,A,1X,A)') cprpt, cdtext, cdstring
3557  WRITE(unit = nulprt1,fmt='(A,1X,A,/)') cpdots, cline
3558  ELSE
3559  WRITE(unit = nulprt1,fmt='(/,A,1X,A,1X,A,/)') cprpt, cdtext, cdstring
3560  ENDIF
3561 !
3562 !
3563 !* 3. End of routine
3564 ! --------------
3565 !
3566  CALL oasis_flush(nulprt1)
3567  ENDIF
3568 
3569 ! call oasis_debug_exit(subname)
3570 
3571  END SUBROUTINE prcout
3572 !===============================================================================
3573 
3574  SUBROUTINE parse (cdone, cdtwo, knumb, klen, kleng, endflag)
3575 !****
3576 ! *****************************
3577 ! * OASIS ROUTINE - LEVEL T *
3578 ! * ------------- ------- *
3579 ! *****************************
3580 !
3581 !**** *parse* - Parsing routine
3582 !
3583 ! Purpose:
3584 ! -------
3585 ! Find the knumb'th string in cdone and put it in cdtwo.
3586 ! A string is defined as a continuous set of non-blanks characters
3587 !
3588 !** Interface:
3589 ! ---------
3590 ! *CALL* *parse (cdone, cdtwo, knumb, klen, kleng)*
3591 !
3592 ! Input:
3593 ! -----
3594 ! cdone : line to be parsed (char string)
3595 ! knumb : rank within the line of the extracted string (integer)
3596 ! klen : length of the input line (integer)
3597 !
3598 ! Output:
3599 ! ------
3600 ! cdtwo : extracted character string (char string)
3601 ! kleng : length of the extracted string (integer)
3602 !
3603 ! Workspace:
3604 ! ---------
3605 ! None
3606 !
3607 ! Externals:
3608 ! ---------
3609 !
3610 ! Reference:
3611 ! ---------
3612 ! See OASIS manual (1995)
3613 !
3614 ! History:
3615 ! -------
3616 ! Version Programmer Date Description
3617 ! ------- ---------- ---- -----------
3618 ! 2.0 L. Terray 95/09/01 created
3619 ! O. Marti 2000/11/08 simplify by using F90
3620 ! CHARACTER functions
3621 !
3622 ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3623 !
3624  IMPLICIT NONE
3625 !
3626 !* ---------------------------- Include files ---------------------------
3627 !
3628 !
3629 !* ---------------------------- Argument declarations -------------------
3630 !
3631  INTEGER (kind=ip_intwp_p), INTENT ( in) :: knumb, klen
3632  CHARACTER (len=klen), INTENT ( inout) :: cdone
3633  CHARACTER (len=klen), INTENT ( out) :: cdtwo
3634  INTEGER (kind=ip_intwp_p), INTENT ( out) :: kleng
3635  LOGICAL, optional, intent(inout) :: endflag
3636 !
3637 !* ---------------------------- Local declarations -------------------
3638 !
3639  integer(kind=ip_intwp_p) :: ii,jl
3640  CHARACTER (len=klen) :: clline
3641  CHARACTER (len=klen) :: clwork
3642  CHARACTER (len=1), SAVE :: clblank = ' ', clcmt = '#'
3643  character(len=*),parameter :: subname='(mod_oasis_namcouple:parse)'
3644 !
3645 !* ---------------------------- Poema verses ----------------------------
3646 
3647 ! call oasis_debug_enter(subname)
3648 
3649 !
3650 ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3651 !
3652 !* 1. Skip line if it is a comment
3653 ! ----------------------------
3654 !
3655  if (present(endflag)) endflag = .false.
3656 
3657 100 IF (cdone(1:1) .NE. clcmt) go to 120
3658  READ (unit = nulin, fmt = 1001, end=249) clline
3659  cdone(1:klen) = clline(1:klen)
3660  go to 100
3661 120 CONTINUE
3662 1001 FORMAT(a5000)
3663 !
3664 !
3665 !* 2. Do the extraction job
3666 ! ---------------------
3667 !
3668 !* - Fill cdtwo with blanks
3669 !
3670  cdtwo = clblank
3671 !
3672 !* Fill temporary string and remove leading blanks
3673 !
3674  clwork = adjustl( cdone)
3675 !
3676 !* - If there are no more characters, kleng=-1
3677 !
3678  IF ( len_trim( clwork) .LE. 0) THEN
3679  kleng = -1
3680 ! call oasis_debug_exit(subname)
3681  RETURN
3682  END IF
3683 !
3684 !* - If this is the one we're looking for, skip
3685 ! otherwise go knumb-1 more sets of characters
3686 !
3687  IF (knumb .GE. 2) THEN
3688  DO jl = 1, knumb-1
3689  ii = index( clwork, clblank) - 1
3690  clwork( 1:ii) = clblank
3691  clwork = adjustl( clwork)
3692 !
3693 !* - If there are no more characters, kleng=-1
3694 !
3695  IF (len_trim( clwork) .LE. 0) THEN
3696  kleng = -1
3697 ! call oasis_debug_exit(subname)
3698  RETURN
3699  END IF
3700  END DO
3701  END IF
3702 !
3703 !* - Find the length of this set of characters
3704 !
3705  kleng = index( clwork, clblank) - 1
3706 !
3707 !* - Copy to cdtwo
3708 !
3709  cdtwo( 1:kleng) = clwork( 1: kleng)
3710 !
3711 !* 3. End of routine
3712 ! --------------
3713 !
3714 ! call oasis_debug_exit(subname)
3715 
3716  return
3717 
3718  249 CONTINUE
3719  IF (present(endflag)) then
3720  endflag = .true.
3721  return
3722  ELSE
3723  IF (mpi_rank_global == 0) THEN
3724  WRITE (unit = nulprt1,fmt = *) ' ***WARNING***'
3725  WRITE (unit = nulprt1,fmt = *) &
3726  ' mod_oasis_namcouple routine parse ran out of input '
3727  WRITE (unit = nulprt1,fmt = *) ' '
3728  WRITE (unit = nulprt1,fmt = *) ' '
3729  WRITE (unit = nulprt1,fmt = *) &
3730  ' We STOP!!! Check the file namcouple'
3731  WRITE (unit = nulprt1,fmt = *) ' '
3732  WRITE (nulprt1,'(a,i4)') ' abort by model ',compid
3733  WRITE (nulprt1,'(a)') ' error = STOP in inipar_alloc'
3734  CALL oasis_flush(nulprt1)
3735  ENDIF
3736  CALL oasis_abort()
3737  ENDIF
3738 
3739  END SUBROUTINE parse
3740 
3741 !===============================================================================
3742 
3743  SUBROUTINE parseblk (cdone, cdtwo, knumb, klen, kleng)
3744 
3745 !****
3746 ! *****************************
3747 ! * OASIS ROUTINE - LEVEL T *
3748 ! * ------------- ------- *
3749 ! *****************************
3750 !
3751 !**** *parse* - Parsing routine
3752 !
3753 ! Purpose:
3754 ! -------
3755 ! Get the rest of the line starting at the knumb'th string.
3756 ! A string is defined as a continuous set of non-blanks characters
3757 !
3758 !** Interface:
3759 ! ---------
3760 ! *CALL* *parseblk (cdone, cdtwo, knumb, klen, kleng)*
3761 !
3762 ! Input:
3763 ! -----
3764 ! cdone : line to be parsed (char string)
3765 ! knumb : rank within the line of the starting string (integer)
3766 ! klen : length of the input line (integer)
3767 !
3768 ! Output:
3769 ! ------
3770 ! cdtwo : extracted rest of line, including blanks (char string)
3771 ! kleng : length of the extracted string (integer)
3772 !
3773 ! Workspace:
3774 ! ---------
3775 ! None
3776 !
3777 ! Externals:
3778 ! ---------
3779 !
3780 ! History:
3781 ! -------
3782 ! Version Programmer Date Description
3783 ! ------- ---------- ---- -----------
3784 ! 2.5 S. Valcke 00/09/08 Adapted from parse.f
3785 !
3786 ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3787 !
3788  IMPLICIT NONE
3789 !
3790 !* ---------------------------- Include files ---------------------------
3791 !
3792 !
3793 !* ---------------------------- Argument declarations -------------------
3794 !
3795  INTEGER (kind=ip_intwp_p), INTENT ( in) :: knumb, klen
3796  CHARACTER (len=klen), INTENT ( inout) :: cdone
3797  CHARACTER (len=klen), INTENT ( out) :: cdtwo
3798  INTEGER (kind=ip_intwp_p), INTENT ( out) :: kleng
3799 !
3800 !* ---------------------------- Local declarations -------------------
3801 !
3802  INTEGER (kind=ip_intwp_p) :: ii,jl
3803  INTEGER (kind=ip_intwp_p) :: il, kleng_aux
3804  CHARACTER (len=klen) :: clline
3805  CHARACTER (len=klen) :: clwork
3806  CHARACTER (len=1), SAVE :: clblank = ' ', clcmt = '#'
3807  character(len=*),parameter :: subname='(mod_oasis_namcouple:parseblk)'
3808 !
3809 !* ---------------------------- Poema verses ----------------------------
3810 
3811 ! call oasis_debug_enter(subname)
3812 
3813 !
3814 ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3815 !
3816 !* 1. Skip line if it is a comment
3817 ! ----------------------------
3818 !
3819 100 IF (cdone(1:1) .NE. clcmt) go to 120
3820  READ (unit = nulin, fmt = 1001) clline
3821  cdone(1:klen) = clline(1:klen)
3822  go to 100
3823 120 CONTINUE
3824 1001 FORMAT(a5000)
3825 !
3826 !
3827 !* 2. Do the extraction job
3828 ! ---------------------
3829 !
3830 !* - Fill cdtwo with blanks
3831 !
3832  cdtwo = clblank
3833 !
3834 !* Fill temporary string and remove leading blanks
3835 !
3836  il = index( cdone, clblank)
3837  kleng_aux = 1
3838  IF (index( cdone, clblank).EQ.1) THEN
3839  DO WHILE (cdone(il+1:il+1).EQ.clblank)
3840  kleng_aux = kleng_aux +1
3841  il = il+1
3842  IF (il+1.GT.klen) go to 130
3843  ENDDO
3844  ENDIF
3845 130 CONTINUE
3846  clwork = adjustl( cdone)
3847 !
3848 !* - If there are no more characters, kleng=-1
3849 !
3850  IF ( len_trim( clwork) .LE. 0) THEN
3851  kleng = -1
3852 ! call oasis_debug_exit(subname)
3853  RETURN
3854  END IF
3855 !
3856 !* - If this is the one we're looking for, skip
3857 ! otherwise go knumb-1 more sets of characters
3858 !
3859  IF (knumb .GE. 2) THEN
3860  DO jl = 1, knumb-1
3861  ii = index( clwork, clblank) - 1
3862  il = ii + 1
3863  DO WHILE (clwork(il:il).EQ.clblank)
3864  kleng_aux = kleng_aux +1
3865  il = il + 1
3866  IF (il.GT.klen) go to 140
3867  ENDDO
3868 140 CONTINUE
3869  kleng_aux = kleng_aux + ii
3870  clwork( 1:ii) = clblank
3871  clwork = adjustl( clwork)
3872 !
3873 !* - If there are no more characters, kleng=-1
3874 !
3875  IF (len_trim( clwork) .LE. 0) THEN
3876  kleng = -1
3877 ! call oasis_debug_exit(subname)
3878  RETURN
3879  END IF
3880  END DO
3881  END IF
3882 !
3883 !* - Find the length of the rest of the line
3884 !
3885  kleng = klen - kleng_aux
3886 !
3887 !* - Copy to cdtwo
3888 !
3889  cdtwo( 1:kleng) = clwork( 1: kleng)
3890 !
3891 !* 3. End of routine
3892 ! --------------
3893 !
3894 
3895 ! call oasis_debug_exit(subname)
3896 
3897  END SUBROUTINE parseblk
3898 !===============================================================================
3899 
3900  SUBROUTINE skip (cd_one, id_len, endflag)
3901 !
3902 !**** SKIP
3903 !
3904 ! Purpose:
3905 ! Skip line if it is a comment
3906 !
3907 ! Interface:
3908 ! Call skip (cl_one)
3909 !
3910 ! Method:
3911 ! Read the first caracter of the line and skip line if
3912 ! it is a comment
3913 !
3914 ! External:
3915 ! none
3916 !
3917 ! Files:
3918 ! none
3919 !
3920 ! References:
3921 !
3922 ! History:
3923 ! --------
3924 ! Version Programmer Date Description
3925 ! ------------------------------------------------
3926 ! 2.5 A.Caubel 2002/04/04 created
3927 !
3928 !*-----------------------------------------------------------------------
3929 !
3930  IMPLICIT NONE
3931 !
3932 !** + DECLARATIONS
3933 !
3934 !
3935 !** ++ Include files
3936 !
3937 !** ++ Argument declarations
3938 !
3939  INTEGER (kind=ip_intwp_p),intent(in) :: id_len
3940  CHARACTER(len=*),intent(inout) :: cd_one
3941  LOGICAL, optional, intent(inout) :: endflag
3942 !
3943 !** ++ Local declarations
3944 !
3945  INTEGER (kind=ip_intwp_p) :: ib
3946  CHARACTER(len=id_len) :: cl_line
3947  CHARACTER(len=1) :: cl_two
3948  character(len=*),parameter :: subname='(mod_oasis_namcouple:skip)'
3949 !
3950 !*-----------------------------------------------------------------------
3951 !
3952 ! call oasis_debug_enter(subname)
3953 
3954  cl_two='#'
3955 100 IF (cd_one(1:1) .NE. cl_two) go to 120
3956  if (present(endflag)) then
3957  endflag = .false.
3958  READ (unit = nulin, fmt = 1001, end=140) cl_line
3959  else
3960  READ (unit = nulin, fmt = 1001) cl_line
3961  endif
3962  cd_one = trim(cl_line)
3963  go to 100
3964 120 CONTINUE
3965  RETURN
3966 140 CONTINUE
3967  endflag = .true.
3968  RETURN
3969 1001 FORMAT(a5000)
3970 !
3971 !*-----------------------------------------------------------------------
3972 !
3973 ! call oasis_debug_exit(subname)
3974 
3975  END SUBROUTINE skip
3976 !
3977 !*========================================================================
3978 !===============================================================================
3979 !===============================================================================
3980 END MODULE mod_oasis_namcouple
3981 
3982 
System type methods.
Reads the namcouple file for use in OASIS.
subroutine prtout(cdtext, kvalue, kstyle)
Provides a generic and simpler interface into MPI calls for OASIS.
subroutine, public oasis_unitsetmin(uio)
Set the minimum unit number allowed.
Provides a common location for several OASIS variables.
Defines kinds for OASIS.
subroutine, public oasis_flush(nu)
Flushes output to file.
Character string manipulation methods.
subroutine skip(cd_one, id_len, endflag)
subroutine, public oasis_unitget(uio)
Get a free unit number.
subroutine parseblk(cdone, cdtwo, knumb, klen, kleng)
subroutine, public oasis_abort(id_compid, cd_routine, cd_message)
OASIS abort method, publically available to users.
subroutine prcout(cdtext, cdstring, kstyle)
subroutine, public oasis_namcouple_init()
Reads the namcouple.
subroutine, public oasis_unitfree(uio)
Release a unit number for reuse.
Defines parameters for OASIS.
subroutine parse(cdone, cdtwo, knumb, klen, kleng, endflag)