Oasis3-MCT
 All Classes Files Functions Variables Macros Pages
mod_oasis_coupler.F90
Go to the documentation of this file.
1 
2 !> Initialize the OASIS coupler infrastructure
3 
5 ! - - - - - - - - - - - - - - - - - - - - - - - - - - -
6 !
11  USE mod_oasis_sys
12  USE mod_oasis_map
13  USE mod_oasis_part
14  USE mod_oasis_var
15  USE mod_oasis_mpi
17  USE mod_oasis_io
18  USE mod_oasis_timer
19  USE mct_mod
20  USE grids ! scrip
21  USE netcdf
22 
23  IMPLICIT NONE
24 
25  private
26 
27  public oasis_coupler_setup
28 
29 ! Type of data
30 
31  public prism_router_type
32  public prism_coupler_type
33 
34 ! COUPLING INFO
35 
36  !> Router information for rearranging data on tasks
38  !--- fixed at initialization ---
39  type(mct_router) :: router !< router
40  end type prism_router_type
41 
42  integer(kind=ip_i4_p),public,parameter :: prism_coupler_avsmax=5 !< maximum number of higher order terms in mapping
43 
44  !> Coupler data for managing all aspects of coupling in OASIS
46  !--- fixed at initialization ---
47  type(mct_avect) :: avect1 !< primary aVect
48  type(mct_avect) :: avect1m !< extra aVect needed for mapping
49  type(mct_avect) :: avect2 !< higher order mapping data
50  type(mct_avect) :: avect3 !< higher order mapping data
51  type(mct_avect) :: avect4 !< higher order mapping data
52  type(mct_avect) :: avect5 !< higher order mapping data
53  logical :: avon(prism_coupler_avsmax) !< flags indicating whether aVects 2-5 are active
54  character(len=ic_xl) :: rstfile !< restart file
55  character(len=ic_xl) :: inpfile !< input file if data is read
56  character(len=ic_xl) :: fldlist !< field list
57  integer(kind=ip_i4_p) :: nflds !< number of fields
58  integer(kind=ip_i4_p),pointer :: varid(:) !< varid for each field
59  logical :: valid !< is this coupler valid
60  integer(kind=ip_i4_p) :: namid !< namcouple ID
61  integer(kind=ip_i4_p) :: partid !< local variable partition ID
62  integer(kind=ip_i4_p) :: rpartid !< router partition ID
63  integer(kind=ip_i4_p) :: routerid !< router ID
64  integer(kind=ip_i4_p) :: mapperid !< mapper ID
65  character(len=ic_med) :: maploc !< map location setting, src or dst
66  integer(kind=ip_i4_p) :: ops !< namcouple operation (ip_exported,...)
67  integer(kind=ip_i4_p) :: comp !< other model compid to couple
68  integer(kind=ip_i4_p) :: tag !< communcation tag
69  integer(kind=ip_i4_p) :: seq !< sequence number
70  integer(kind=ip_i4_p) :: dt !< coupling period (secs)
71  integer(kind=ip_i4_p) :: lag !< put lag positive is put sooner (secs)
72  integer(kind=ip_i4_p) :: maxtime !< max time for the coupler
73  integer(kind=ip_i4_p) :: trans !< transformation (ip_average,...)
74  integer(kind=ip_i4_p) :: conserv !< conserve operation (ip_cnone,ip_cglobal,...)
75  character(len=ic_med) :: consopt !< conserve option (bfb, opt)
76  integer(kind=ip_i4_p) :: getput !< get/put flag
77  logical :: sndrcv !< send recv flag
78  logical :: output !< output flag
79  logical :: input !< input flag
80  logical :: snddiag !< diagnose src fields as part of coupling
81  logical :: rcvdiag !< diagnose rcv fields as part of coupling
82  real(kind=ip_double_p):: sndmult !< send field multiplier term
83  real(kind=ip_double_p):: sndadd !< send field addition term
84  real(kind=ip_double_p):: rcvmult !< receive field multiplier term
85  real(kind=ip_double_p):: rcvadd !< receive field addition term
86  !--- time varying info ---
87  integer(kind=ip_i4_p) :: ltime !< time at last coupling
88  integer(kind=ip_i4_p),pointer :: avcnt(:) !< counter for averaging
89  integer(kind=ip_i4_p),pointer :: status(:) !< status of variables in coupler
90  end type prism_coupler_type
91 
92  integer(kind=ip_i4_p) :: prism_mrouter !< max routers
93  integer(kind=ip_i4_p) :: prism_nrouter = 0 !< router counter
94  type(prism_router_type) ,public, pointer:: prism_router(:) !< prism_router array
95 
96  integer(kind=ip_i4_p) ,public :: prism_mcoupler !< max couplers
97  type(prism_coupler_type),public, pointer :: prism_coupler_put(:) !< prism_coupler put array
98  type(prism_coupler_type),public, pointer :: prism_coupler_get(:) !< prism_coupler get array
99 
100  integer(kind=ip_i4_p) ,public :: lcouplerid !< last coupler id
101  integer(kind=ip_i4_p) ,public :: lcouplertime !< last coupler time
102  integer(kind=ip_i4_p) ,public :: lastseq !< last coupler sequence
103  integer(kind=ip_i4_p) ,public :: lastseqtime !< last coupler sequence time
104 
105 
106 !#include <netcdf.inc>
107 
108 !------------------------------------------------------------
109 CONTAINS
110 !------------------------------------------------------------
111 
112 !> Main routine to setup couplers
113 
114 !> This routine initializes all the coupler data based on the namcouple
115 !> inputs and the calls into the OASIS initialization interfaces from models.
116 !> It reconciles everything. This is called from oasis_enddef.
117 
118  SUBROUTINE oasis_coupler_setup()
119 
120  !----------------------------------------------------------
121  ! This routine reconciles the coupling stuff
122  !----------------------------------------------------------
123 
124  IMPLICIT none
125 
126  integer(kind=ip_i4_p) :: n,n1,n2,nn,nv,nm,nv1,nv1a,nns,lnn,nc,nf,nvf,npc,r1
127  integer(kind=ip_i4_p) :: pe
128  integer(kind=ip_i4_p) :: part1, part2
129  integer(kind=ip_i4_p) :: spart,dpart ! src, dst partitions for mapping
130  ! part1 = my local part, partID
131  ! part2 = other partition for mapping
132  ! spart = src part for mapping; put=part1, get=part2
133  ! dpart = dst part for mapping; put=part2, get=part1
134  integer(kind=ip_i4_p) :: mapID,namID
135  type(mct_smat),pointer :: sMati(:)
136  integer(kind=ip_i4_p) :: ncid,dimid,status
137  integer(kind=ip_i4_p) :: lsize,gsize
138  integer(kind=ip_i4_p) :: svarid
139  integer(kind=ip_i4_p),allocatable :: varidtmp(:)
140  integer(kind=ip_i4_p) :: part
141  character(len=ic_med) :: cstring
142  character(len=ic_lvar):: myfld
143  integer(kind=ip_i4_p) :: myfldi
144  character(len=ic_xl) :: myfldlist ! field list
145  character(len=ic_lvar):: otfld
146  character(len=ic_xl) :: otfldlist ! field list
147  integer(kind=ip_i4_p) :: nx,ny
148  character(len=ic_lvar):: gridname
149  character(len=ic_long):: tmp_mapfile
150  integer(kind=ip_i4_p) :: flag
151  logical :: found, exists, found2
152  integer(kind=ip_i4_p) :: mynvar
153  integer(kind=ip_i4_p) :: nwgts
154  character(len=ic_lvar):: tmpfld
155  type(prism_coupler_type),pointer :: pcpointer
156  type(prism_coupler_type),pointer :: pcpntpair
157  integer(kind=ip_i4_p) :: ifind,nfind
158  character(len=ic_lvar),pointer :: myvar(:)
159  integer(kind=ip_i4_p) ,pointer :: myops(:)
160  integer(kind=ip_i4_p) ,pointer :: nallvar(:)
161  character(len=ic_lvar),pointer :: allvar(:,:)
162  integer(kind=ip_i4_p) ,pointer :: allops(:,:)
163  integer(kind=ip_i4_p) ,pointer :: namsrc_checkused(:) ! 0 = not used
164  integer(kind=ip_i4_p) ,pointer :: namsrc_checkused_g(:) ! 0 = not used
165  type sortnamfld_type
166  integer(kind=ip_i4_p) :: num ! total number of namcouple fields
167  integer(kind=ip_i4_p) ,pointer :: namnum(:) ! namcouple number
168  integer(kind=ip_i4_p) ,pointer :: fldnum(:) ! namcouple field number in namcouple
169  character(len=ic_lvar),pointer :: fld(:) ! namcouple field name
170  end type sortnamfld_type
171  type(sortnamfld_type) :: sortnsrc
172  type(sortnamfld_type) :: sortndst
173  type sortvarfld_type
174  integer(kind=ip_i4_p) :: num ! total number of var fields
175  integer(kind=ip_i4_p) ,pointer :: modnum(:) ! model number
176  integer(kind=ip_i4_p) ,pointer :: varnum(:) ! var field number in model
177  character(len=ic_lvar),pointer :: fld(:) ! variable field name
178  end type sortvarfld_type
179  type(sortvarfld_type) :: sortvars
180  type(sortvarfld_type) :: sorttest
181  integer(kind=ip_i4_p) ,pointer :: sortkey(:)
182 ! character(len=*),parameter :: smatread_method = 'orig'
183  character(len=*),parameter :: smatread_method = 'ceg'
184  logical, parameter :: local_timers_on = .false.
185 
186  character(len=*),parameter :: subname = '(oasis_coupler_setup)'
187 
188  !----------------------------------------------------------
189 
190  call oasis_debug_enter(subname)
191 ! call oasis_mpi_barrier(mpi_comm_global)
192  call oasis_timer_start('cpl_setup')
193 
194  if (local_timers_on) call oasis_timer_start('cpl_setup_n1')
195 
196  write(nulprt,*) subname,' smatread_method = ',trim(smatread_method)
197 
198  !-----------------------------------------
199  !> * Allocate and zero prism_router, prism_mapper, prism_coupler based on nnamcpl
200  ! there cannot be more than that needed
201  !-----------------------------------------
202 
203  call oasis_debug_note(subname//' set defaults for datatypes')
204 
205  prism_mrouter = nnamcpl * 2 ! multiply by 2 for coupling to self
206  allocate(prism_router(prism_mrouter))
207  prism_nrouter = 0
208 
209  prism_mmapper = nnamcpl
210  allocate(prism_mapper(prism_mmapper))
211  prism_nmapper = 0
212  prism_mapper(:)%nwgts = 0
213  prism_mapper(:)%file = ""
214  prism_mapper(:)%loc = ""
215  prism_mapper(:)%opt = ""
216  prism_mapper(:)%optval= ""
217  prism_mapper(:)%init = .false.
218  prism_mapper(:)%spart = ispval
219  prism_mapper(:)%dpart = ispval
220  prism_mapper(:)%AVred = .false.
221 
222  prism_mcoupler = nnamcpl
223  allocate(prism_coupler_put(prism_mcoupler))
224  allocate(prism_coupler_get(prism_mcoupler))
225 
226  do nc = 1,prism_mcoupler
227  do npc = 1,2
228  if (npc == 1) then
229  pcpointer => prism_coupler_put(nc)
230  pcpntpair => prism_coupler_get(nc)
231  endif
232  if (npc == 2) then
233  pcpointer => prism_coupler_get(nc)
234  pcpntpair => prism_coupler_put(nc)
235  endif
236  pcpointer%rstfile = ""
237  pcpointer%inpfile = ""
238  pcpointer%fldlist = ""
239  pcpointer%nflds = 0
240  pcpointer%namID = 0
241  pcpointer%valid = .false.
242 !tcx is this alloc pcpointer or prism_coupler_*
243  allocate(pcpointer%varid(1))
244  pcpointer%varid(:) = ispval
245  pcpointer%aVon(:) = .false.
246  pcpointer%ops = ispval
247  pcpointer%comp = ispval
248  pcpointer%routerID = ispval
249  pcpointer%mapperID = ispval
250  pcpointer%maploc = ""
251  pcpointer%tag = ispval
252  pcpointer%dt = ispval
253  pcpointer%lag = 0
254  pcpointer%maxtime = 0
255  pcpointer%getput = ispval
256  pcpointer%sndrcv = .false.
257  pcpointer%output = .false.
258  pcpointer%input = .false.
259  pcpointer%trans = ip_instant
260  pcpointer%conserv = ip_cnone
261  pcpointer%ltime = ispval
262  pcpointer%snddiag = .false.
263  pcpointer%rcvdiag = .false.
264  pcpointer%sndmult = 1.0_ip_double_p
265  pcpointer%sndadd = 0.0_ip_double_p
266  pcpointer%rcvmult = 1.0_ip_double_p
267  pcpointer%rcvadd = 0.0_ip_double_p
268  enddo ! npc
269  enddo ! nc
270 
271  lcouplerid = ispval
272  lcouplertime = ispval
273  lastseq = ispval
274  lastseqtime = ispval
275 
276  !----------------------------------------------------------
277  !> * Generate model variable lists across all models based on def_var calls.
278  !> These will be reconciled with the namcouple input. These are sorted
279  !> to improve search performance later.
280  !----------------------------------------------------------
281 
282  call oasis_debug_note(subname//' share var info between models')
283 
284  allocate(allvar(maxvar,prism_amodels))
285  allocate(nallvar(prism_amodels))
286  allocate(allops(maxvar,prism_amodels))
287  allocate(myvar(maxvar))
288  allocate(myops(maxvar))
289 
290  allvar = " "
291  nallvar = 0
292  allops = -1
293  if (local_timers_on) call oasis_timer_start('cpl_setup_n1_bcast')
294  do n = 1,prism_amodels
295  if (n == compid) then
296  myvar = " "
297  myops = 0
298  mynvar = prism_nvar
299  do n1 = 1, prism_nvar
300  myvar(n1) = trim(prism_var(n1)%name)
301  myops(n1) = prism_var(n1)%ops
302  ! check that each var name is unique for a given model
303  do n2 = 1,n1-1
304  if (myvar(n1) == myvar(n2)) then
305  WRITE(nulprt,*) subname,estr,'variable name defined more than once by def_var = ',trim(myvar(n1))
306  call oasis_abort()
307  endif
308  enddo
309  enddo
310  endif
311  if (oasis_debug >= 5) then
312  write(nulprt,*) subname,' BCAST from ',n,mpi_root_global(n)
313  call oasis_flush(nulprt)
314  endif
315  call oasis_mpi_bcast(mynvar,mpi_comm_global,'mynvar',mpi_root_global(n))
316  if (oasis_debug >= 5) then
317  write(nulprt,*) subname,' bcast mynvar ',mynvar
318  call oasis_flush(nulprt)
319  endif
320  nallvar(n) = mynvar
321  call oasis_mpi_bcast(myvar,mpi_comm_global,'myvar',mpi_root_global(n))
322  if (oasis_debug >= 5) then
323  write(nulprt,*) subname,' bcast myvar ',trim(myvar(1))
324  call oasis_flush(nulprt)
325  endif
326  allvar(:,n) = myvar(:)
327  call oasis_mpi_bcast(myops,mpi_comm_global,'myops',mpi_root_global(n))
328  if (oasis_debug >= 5) then
329  write(nulprt,*) subname,' bcast myops ',myops(1)
330  call oasis_flush(nulprt)
331  endif
332  allops(:,n) = myops(:)
333  enddo
334  if (local_timers_on) call oasis_timer_stop('cpl_setup_n1_bcast')
335 
336  deallocate(myvar,myops)
337 
338  if (oasis_debug >= 2) then
339  write(nulprt,*) subname,' model variable info:'
340  do nm = 1,prism_amodels
341  write(nulprt,'(8x,a,2i6)') ' model,nvars = ',nm,nallvar(nm)
342  do nv = 1,nallvar(nm)
343  cstring = 'unknown'
344  if (allops(nv,nm) == oasis_out) cstring = 'prism_out'
345  if (allops(nv,nm) == oasis_in) cstring = 'prism_in'
346  write(nulprt,'(16x,a,2i6,2x,a,i6,2x,a)') ' model,idx,var,ops = ',nm,nv,&
347  trim(allvar(nv,nm)),allops(nv,nm),&
348  trim(cstring)
349  enddo
350  enddo
351  write(nulprt,*) ' '
352  call oasis_flush(nulprt)
353  endif
354 
355  ! generate sortvars sorted list
356 
357  n1 = 0
358  do n = 1,prism_amodels
359  n1 = n1 + nallvar(n)
360  enddo
361  allocate(sortvars%fld(n1))
362  allocate(sortvars%modnum(n1))
363  allocate(sortvars%varnum(n1))
364  allocate(sortkey(n1))
365  sortvars%num = n1
366 
367  n1 = 0
368  do n = 1,prism_amodels
369  do n2 = 1,nallvar(n)
370  n1 = n1 + 1
371  sortkey(n1) = n1
372  sortvars%fld(n1) = allvar(n2,n)
373  sortvars%modnum(n1) = n
374  sortvars%varnum(n1) = n2
375  enddo
376  enddo
377 
378  call cplsort(sortvars%num, sortvars%fld, sortkey)
379  call cplsortkey(sortvars%num, sortvars%modnum, sortkey)
380  call cplsortkey(sortvars%num, sortvars%varnum, sortkey)
381 
382  if (oasis_debug >= 15) then
383  write(nulprt,*) subname//' Sorted array : sortvars'
384  do n1 = 1,sortvars%num
385  write(nulprt,*) subname,'sort sortvars',n1,sortkey(n1),sortvars%modnum(n1),sortvars%varnum(n1),trim(sortvars%fld(n1))
386  enddo
387  endif
388 
389  deallocate(sortkey)
390 
391  !----------------------------------------------------------
392  !> * Setup couplers based on namcouple and model variable info.
393  ! These must be paired up consistently, create couplers in
394  ! sorted order (nns)
395  ! nn = namcpl counter, sorted
396  ! nm = model counter, compid is my nm
397  ! nv = variable counter
398  ! nv1 = my variable counter
399  !----------------------------------------------------------
400 
401  if (local_timers_on) call oasis_timer_stop('cpl_setup_n1')
402 
403  !--------------------------------
404  !> * Preprocess namcouple strings and sort for faster searches
405  !--------------------------------
406 
407  ! count namcouple field names
408 
409  if (local_timers_on) call oasis_timer_start('cpl_setup_n2')
410  n1 = 0
411  n2 = 0
412  do nn = 1,nnamcpl
413  n1 = n1 + oasis_string_listgetnum(namsrcfld(nn))
414  n2 = n2 + oasis_string_listgetnum(namdstfld(nn))
415  if (n1 /= n2) then
416  WRITE(nulprt,*) subname,estr,'number of fields in namcouple inconsistent ',nn,n1,n2
417  WRITE(nulprt,*) subname,estr,'namcouple src fields = ',trim(namsrcfld(nn))
418  WRITE(nulprt,*) subname,estr,'namcouple dst fields = ',trim(namdstfld(nn))
419  call oasis_abort()
420  endif
421  enddo
422 
423  ! allocate space
424  ! note: n2==n1
425 
426  sortnsrc%num = n1
427  allocate(sortnsrc%fld(n1))
428  allocate(sortnsrc%namnum(n1))
429  allocate(sortnsrc%fldnum(n1))
430  sortndst%num = n2
431  allocate(sortndst%fld(n2))
432  allocate(sortndst%namnum(n2))
433  allocate(sortndst%fldnum(n2))
434 
435  ! this will check that all namcouple vars are used in application
436  allocate(namsrc_checkused(sortnsrc%num))
437  namsrc_checkused = 0
438 
439  ! fill and sort sortnsrc
440 
441  allocate(sortkey(sortnsrc%num))
442  n1 = 0
443  do nn = 1,nnamcpl
444  do n2 = 1,oasis_string_listgetnum(namsrcfld(nn))
445  n1 = n1 + 1
446  sortkey(n1) = n1
447  sortnsrc%namnum(n1) = nn
448  sortnsrc%fldnum(n1) = n2
449  call oasis_string_listgetname(namsrcfld(nn),n2,sortnsrc%fld(n1))
450  enddo
451  enddo
452 
453  call cplsort(sortnsrc%num, sortnsrc%fld, sortkey)
454  call cplsortkey(sortnsrc%num, sortnsrc%namnum, sortkey)
455  call cplsortkey(sortnsrc%num, sortnsrc%fldnum, sortkey)
456 
457  if (oasis_debug >= 15) then
458  write(nulprt,*) subname//' Sorted array : sortnsrc'
459  do n1 = 1,sortnsrc%num
460  write(nulprt,*) subname,'sort sortnsrc',n1,sortkey(n1), &
461  sortnsrc%namnum(n1),sortnsrc%fldnum(n1),trim(sortnsrc%fld(n1))
462  enddo
463  endif
464  deallocate(sortkey)
465 
466  ! fill and sort sortndst
467 
468  allocate(sortkey(sortndst%num))
469  n1 = 0
470  do nn = 1,nnamcpl
471  do n2 = 1,oasis_string_listgetnum(namdstfld(nn))
472  n1 = n1 + 1
473  sortkey(n1) = n1
474  sortndst%namnum(n1) = nn
475  sortndst%fldnum(n1) = n2
476  call oasis_string_listgetname(namdstfld(nn),n2,sortndst%fld(n1))
477  enddo
478  enddo
479 
480  call cplsort(sortndst%num, sortndst%fld, sortkey)
481  call cplsortkey(sortndst%num, sortndst%namnum, sortkey)
482  call cplsortkey(sortndst%num, sortndst%fldnum, sortkey)
483 
484  if (oasis_debug >= 15) then
485  write(nulprt,*) subname//' Sorted array : sortndst'
486  do n1 = 1,sortndst%num
487  write(nulprt,*) subname,'sort sortndst',n1,sortkey(n1), &
488  sortndst%namnum(n1),sortndst%fldnum(n1),trim(sortndst%fld(n1))
489  enddo
490  endif
491  deallocate(sortkey)
492 
493  if (oasis_debug >= 1500) then
494 
495  write(nulprt,*) subname,' Test sort code: '
496 
497  n1 = 10
498  allocate(sorttest%fld(n1))
499  allocate(sorttest%modnum(n1))
500  allocate(sorttest%varnum(n1))
501  allocate(sortkey(n1))
502  sorttest%num = n1
503 
504  sorttest%fld(:) = 'A'
505  do n1 = 1,sorttest%num
506  sortkey(n1) = n1
507  if (n1 == 1) sorttest%fld(n1) = 'D'
508  if (n1 == 2) sorttest%fld(n1) = 'C'
509  if (n1 == 4) sorttest%fld(n1) = 'C'
510  if (n1 == 5) sorttest%fld(n1) = 'D'
511  if (n1 == 8) sorttest%fld(n1) = 'C'
512  if (n1 == 9) sorttest%fld(n1) = 'B'
513  if (n1 == 10) sorttest%fld(n1) = 'C'
514  sorttest%modnum(n1) = n1+100
515  sorttest%varnum(n1) = n1
516  enddo
517 
518  call cplsort(sorttest%num, sorttest%fld, sortkey)
519  call cplsortkey(sorttest%num, sorttest%modnum, sortkey)
520  call cplsortkey(sorttest%num, sorttest%varnum, sortkey)
521 
522  write(nulprt,*) subname//' Sorted array : sorttest'
523  do n1 = 1,sorttest%num
524  write(nulprt,*) subname,'sort sorttest',n1,sortkey(n1), &
525  sorttest%modnum(n1),sorttest%varnum(n1),trim(sorttest%fld(n1))
526  enddo
527 
528  tmpfld = 'A'
529  call cplfind(sorttest%num, sorttest%fld, tmpfld, ifind, nfind)
530  write(nulprt,*) subname,' cpl find1 ',trim(tmpfld),ifind,nfind
531  do n1 = ifind,ifind+nfind-1
532  write(nulprt,*) subname,' cpl find2 ',n1,trim(sorttest%fld(n1))
533  enddo
534 
535  tmpfld = 'B'
536  call cplfind(sorttest%num, sorttest%fld, tmpfld, ifind, nfind)
537  write(nulprt,*) subname,' cpl find1 ',trim(tmpfld),ifind,nfind
538  do n1 = ifind,ifind+nfind-1
539  write(nulprt,*) subname,' cpl find2 ',n1,trim(sorttest%fld(n1))
540  enddo
541 
542  tmpfld = 'C'
543  call cplfind(sorttest%num, sorttest%fld, tmpfld, ifind, nfind)
544  write(nulprt,*) subname,' cpl find1 ',trim(tmpfld),ifind,nfind
545  do n1 = ifind,ifind+nfind-1
546  write(nulprt,*) subname,' cpl find2 ',n1,trim(sorttest%fld(n1))
547  enddo
548 
549  tmpfld = 'D'
550  call cplfind(sorttest%num, sorttest%fld, tmpfld, ifind, nfind)
551  write(nulprt,*) subname,' cpl find1 ',trim(tmpfld),ifind,nfind
552  do n1 = ifind,ifind+nfind-1
553  write(nulprt,*) subname,' cpl find2 ',n1,trim(sorttest%fld(n1))
554  enddo
555 
556  tmpfld = 'E'
557  call cplfind(sorttest%num, sorttest%fld, tmpfld, ifind, nfind)
558  write(nulprt,*) subname,' cpl find1 ',trim(tmpfld),ifind,nfind
559  do n1 = ifind,ifind+nfind-1
560  write(nulprt,*) subname,' cpl find2 ',n1,trim(sorttest%fld(n1))
561  enddo
562 
563  deallocate(sortkey)
564  deallocate(sorttest%fld)
565  deallocate(sorttest%modnum)
566  deallocate(sorttest%varnum)
567 
568  write(nulprt,*) subname,' Test cplfind: '
569  n1 = max(min(sortndst%num,sortndst%num/3),1)
570  tmpfld = sortndst%fld(n1)
571  call cplfind(sortndst%num, sortndst%fld, tmpfld, ifind, nfind)
572  write(nulprt,*) subname,' cpl find1 ',trim(tmpfld),ifind,nfind
573  do n1 = ifind,ifind+nfind-1
574  write(nulprt,*) subname,' cpl find2 ',n1,trim(sortndst%fld(n1))
575  enddo
576 
577  n1 = max(min(sortndst%num,1),1)
578  tmpfld = sortndst%fld(n1)
579  call cplfind(sortndst%num, sortndst%fld, tmpfld, ifind, nfind)
580  write(nulprt,*) subname,' cpl find1 ',trim(tmpfld),ifind,nfind
581  do n1 = ifind,ifind+nfind-1
582  write(nulprt,*) subname,' cpl find2 ',n1,trim(sortndst%fld(n1))
583  enddo
584 
585  n1 = max(min(sortndst%num,2),1)
586  tmpfld = sortndst%fld(n1)
587  call cplfind(sortndst%num, sortndst%fld, tmpfld, ifind, nfind)
588  write(nulprt,*) subname,' cpl find1 ',trim(tmpfld),ifind,nfind
589  do n1 = ifind,ifind+nfind-1
590  write(nulprt,*) subname,' cpl find2 ',n1,trim(sortndst%fld(n1))
591  enddo
592 
593  n1 = max(min(sortndst%num,sortndst%num-1),1)
594  tmpfld = sortndst%fld(n1)
595  call cplfind(sortndst%num, sortndst%fld, tmpfld, ifind, nfind)
596  write(nulprt,*) subname,' cpl find1 ',trim(tmpfld),ifind,nfind
597  do n1 = ifind,ifind+nfind-1
598  write(nulprt,*) subname,' cpl find2 ',n1,trim(sortndst%fld(n1))
599  enddo
600 
601  n1 = max(min(sortndst%num,sortndst%num),1)
602  tmpfld = sortndst%fld(n1)
603  call cplfind(sortndst%num, sortndst%fld, tmpfld, ifind, nfind)
604  write(nulprt,*) subname,' cpl find1 ',trim(tmpfld),ifind,nfind
605  do n1 = ifind,ifind+nfind-1
606  write(nulprt,*) subname,' cpl find2 ',n1,trim(sortndst%fld(n1))
607  enddo
608 
609  CALL oasis_flush(nulprt)
610  endif
611 
612  if (local_timers_on) call oasis_timer_stop('cpl_setup_n2')
613 
614  call oasis_debug_note(subname//' compare vars and namcouple')
615  call oasis_debug_note(subname//' setup couplers')
616 
617  if (local_timers_on) call oasis_timer_start('cpl_setup_n3')
618 
619  !--------------------------------
620  !> * Loop over all my model variables
621  !--------------------------------
622 
623  do nv1 = 1,prism_nvar
624 
625  !--------------------------------
626  !> * Get parition and field information
627  !--------------------------------
628 
629  part1 = prism_var(nv1)%part
630  myfld = prism_var(nv1)%name
631 
632  IF (oasis_debug >= 20) THEN
633  WRITE(nulprt,*) ' '
634  WRITE(nulprt,*) subname,' get part and fld ',nv1,part1,trim(myfld)
635  CALL oasis_flush(nulprt)
636  ENDIF
637 
638  !--------------------------------
639  !> * Check if variable is In or Out and then find namcouple matches
640  !--------------------------------
641 
642  if (local_timers_on) call oasis_timer_start('cpl_setup_n3a')
643  if (prism_var(nv1)%ops == oasis_out) then
644  call cplfind(sortnsrc%num, sortnsrc%fld, myfld, ifind, nfind)
645  elseif (prism_var(nv1)%ops == oasis_in) then
646  call cplfind(sortndst%num, sortndst%fld, myfld, ifind, nfind)
647  endif
648  if (local_timers_on) call oasis_timer_stop('cpl_setup_n3a')
649 
650  !--------------------------------
651  !> * Loop over the namcouple matches
652  !--------------------------------
653  do nf = ifind,ifind+nfind-1
654  if (local_timers_on) call oasis_timer_start('cpl_setup_n3b')
655 
656  flag = oasis_notdef
657 
658  if (prism_var(nv1)%ops == oasis_out) then
659  nn = sortnsrc%namnum(nf)
660  myfldi = sortnsrc%fldnum(nf)
661  myfldlist = namsrcfld(nn)
662  otfldlist = namdstfld(nn)
663  flag = oasis_out
664  elseif (prism_var(nv1)%ops == oasis_in) then
665  nn = sortndst%namnum(nf)
666  myfldi = sortndst%fldnum(nf)
667  myfldlist = namdstfld(nn)
668  otfldlist = namsrcfld(nn)
669  flag = oasis_in
670  endif
671 
672  nns = namnn2sort(nn)
673 
674  IF (oasis_debug >= 20) THEN
675  WRITE(nulprt,*) subname,' found fld1 ',trim(myfld),nv1,nf
676  WRITE(nulprt,*) subname,' found fld2 ',trim(myfld),nns,nn,myfldi,flag
677  CALL oasis_flush(nulprt)
678  ENDIF
679 
680  if (local_timers_on) call oasis_timer_stop('cpl_setup_n3b')
681 
682  !--------------------------------
683  ! my variable is in this namcouple input
684  !--------------------------------
685 
686  if (flag /= oasis_notdef) then
687 
688  if (local_timers_on) call oasis_timer_start('cpl_setup_n3c')
689 
690  !--------------------------------
691  !> * Migrate namcouple info into part
692  !--------------------------------
693 
694  IF (oasis_debug >= 20) THEN
695  WRITE(nulprt,*) subname,' migrate namcouple to part '
696  CALL oasis_flush(nulprt)
697  ENDIF
698 
699  if (flag == oasis_in) then
700  if (prism_part(part1)%nx < 1) then
701  prism_part(part1)%nx = namdst_nx(nn)
702  prism_part(part1)%ny = namdst_ny(nn)
703  prism_part(part1)%gridname = trim(namdstgrd(nn))
704  endif
705  endif
706  if (flag == oasis_out) then
707  if (prism_part(part1)%nx < 1) then
708  prism_part(part1)%nx = namsrc_nx(nn)
709  prism_part(part1)%ny = namsrc_ny(nn)
710  prism_part(part1)%gridname = trim(namsrcgrd(nn))
711  endif
712  endif
713 
714  !--------------------------------
715  !> * Make sure it's either an In or Out, sanity check
716  !--------------------------------
717 
718  if (flag /= oasis_in .and. flag /= oasis_out) then
719  write(nulprt,*) subname,estr,'var must be either OASIS_In or OASIS_Out for var = ',trim(myfld)
720  call oasis_abort()
721  endif
722 
723  if (oasis_debug >= 20) then
724  write(nulprt,'(1x,2a,4i6,2a)') subname,' ca: myfld',nn,compid,&
725  nv1,myfldi,' ',trim(myfld)
726  call oasis_flush(nulprt)
727  endif
728 
729  !--------------------------------
730  !> * Determine matching field name from namcouple
731  !--------------------------------
732 
733  if (local_timers_on) call oasis_timer_start('cpl_setup_n3c1')
734  otfld = 'NOmatchNOyesNOyesNO'
735  call oasis_string_listgetname(otfldlist,myfldi,otfld)
736  if (local_timers_on) call oasis_timer_stop('cpl_setup_n3c1')
737 
738  IF (oasis_debug >= 20) THEN
739  WRITE(nulprt,*) subname,' otfld ',trim(otfld)
740  CALL oasis_flush(nulprt)
741  ENDIF
742 
743  !--------------------------------
744  !> * Search for list of models with other variable
745  !--------------------------------
746 
747  if (local_timers_on) call oasis_timer_start('cpl_setup_n3c2')
748  call cplfind(sortvars%num, sortvars%fld, otfld, ifind, nfind)
749  if (local_timers_on) call oasis_timer_stop('cpl_setup_n3c2')
750  if (local_timers_on) call oasis_timer_stop('cpl_setup_n3c')
751 
752  !--------------------------------
753  !> * Loop over those other matching variable names
754  !--------------------------------
755  found = .false.
756  do nvf = ifind, ifind+nfind-1
757 
758  ! check used appropriate array value, we are using "src" side sorted list
759  ! if output, just set the nf value
760  ! if input, search for an nn and myfldi match in the list
761 
762  if (prism_var(nv1)%ops == oasis_out) then
763  namsrc_checkused(nf) = 1
764  if (oasis_debug >= 20) then
765  write(nulprt,*) subname,' set src checkused ',trim(myfld),':',trim(otfld),nf
766  call oasis_flush(nulprt)
767  endif
768  endif
769  if (prism_var(nv1)%ops == oasis_in) then
770  n1 = 0
771  found2 = .false.
772  do while (n1 < sortnsrc%num .and. .not.found2)
773  n1 = n1 + 1
774  if (nn == sortnsrc%namnum(n1) .and. myfldi == sortnsrc%fldnum(n1)) then
775  namsrc_checkused(n1) = 1
776  found2 = .true.
777  if (oasis_debug >= 20) then
778  write(nulprt,*) subname,' set dst checkused ',trim(myfld),':',trim(otfld),n1
779  call oasis_flush(nulprt)
780  endif
781  endif
782  enddo
783  endif
784 
785  if (local_timers_on) call oasis_timer_start('cpl_setup_n3d')
786  nm = sortvars%modnum(nvf)
787  nv = sortvars%varnum(nvf)
788 
789  if (oasis_debug >= 20) then
790  write(nulprt,*) subname,' match otfld ',trim(otfld),nn
791  call oasis_flush(nulprt)
792  endif
793 
794  !--------------------------------
795  !> * Check that one side is In and other side is Out for communication
796  !> * Check if input or output, field name should match on both sides.
797  !--------------------------------
798 
799  if (namfldops(nn) == ip_exported .or. namfldops(nn) == ip_expout) then
800 ! tcraig allow this now
801 ! if (nm == compid) then
802 ! write(nulprt,*) subname,estr,'send recv pair on same model = ', &
803 ! trim(myfld),' ',trim(otfld)
804 ! call oasis_abort()
805 ! endif
806  if (flag == oasis_out .and. allops(nv,nm) /= oasis_in) then
807  write(nulprt,*) subname,estr,'send recv pair both Out = ', &
808  trim(myfld),' ',trim(otfld)
809  call oasis_abort()
810  endif
811  if (flag == oasis_in .and. allops(nv,nm) /= oasis_out) then
812  write(nulprt,*) subname,estr,'send recv pair both In = ', &
813  trim(myfld),' ',trim(otfld)
814  call oasis_abort()
815  endif
816  endif
817 
818  if (namfldops(nn) == ip_input .or. namfldops(nn) == ip_output) then
819  if (trim(myfld) /= trim(otfld)) then
820  write(nulprt,*) subname,estr,'namcouple field names do not match in/out = ', &
821  trim(myfld),' ',trim(otfld)
822  call oasis_abort()
823  endif
824  endif
825 
826  !--------------------------------
827  ! Only an error to find two sources for a destination
828  ! Not an error if a two destinations have a single source
829  !--------------------------------
830 
831  if (flag == oasis_in .and. found) then
832  write(nulprt,*) subname,estr,'found two sources for field = ',trim(otfld)
833  call oasis_abort()
834  endif
835  found = .true.
836 
837  nc = nns
838  if (flag == oasis_out) pcpointer => prism_coupler_put(nc)
839  if (flag == oasis_in) pcpointer => prism_coupler_get(nc)
840 
841  !--------------------------------
842  !> * Generate field list, multiple field support
843  !--------------------------------
844 
845  IF (oasis_debug >= 20) THEN
846  WRITE(nulprt,*) subname,' set prism_coupler '
847  CALL oasis_flush(nulprt)
848  ENDIF
849 
850  ! tcraig, changed this to make sure order of fields in list matches on all tasks
851  ! Use the field lists in the namcouple
852  ! Assumes all namcoupler variables are coupled
853  ! The nflds counter doesn't do much anymore here
854  ! The varid size should be size(myfldlist)
855  ! Will need to change IF all namcoupler variables don't need to be coupled
856 
857  pcpointer%nflds = pcpointer%nflds + 1
858 
859 !tcx
860 ! this used to add fields to list one at a time
861 ! svarid = size(pcpointer%varid)
862 ! if (pcpointer%nflds > svarid) then
863 ! allocate(varidtmp(svarid))
864 ! varidtmp(1:svarid) = pcpointer%varid(1:svarid)
865 ! deallocate(pcpointer%varid)
866 ! allocate(pcpointer%varid(pcpointer%nflds+10))
867 ! pcpointer%varid(1:svarid) = varidtmp(1:svarid)
868 ! deallocate(varidtmp)
869 ! endif
870 !
871 ! if (pcpointer%nflds == 1) then
872 ! pcpointer%fldlist = trim(myfld)
873 ! else
874 ! pcpointer%fldlist = trim(pcpointer%fldlist)//':'//trim(myfld)
875 ! endif
876 ! pcpointer%varid(pcpointer%nflds) = nv1
877 !tcx
878 
879  if (pcpointer%nflds == 1) then
880  pcpointer%fldlist = trim(myfldlist)
881  deallocate(pcpointer%varid)
882  allocate(pcpointer%varid(oasis_string_listgetnum(myfldlist)))
883  pcpointer%varid(:) = ispval
884  endif
885 
886  svarid = size(pcpointer%varid)
887  if (myfldi > svarid .or. pcpointer%nflds > svarid) then
888  WRITE(nulprt,*) subname,estr,'multiple field coupling setup error',svarid,myfldi,pcpointer%nflds
889  call oasis_abort()
890  endif
891 
892  pcpointer%varid(myfldi) = nv1
893 
894  !--------------------------------
895  !> * Add this coupler to list of prism_var couplers
896  !--------------------------------
897 
898  prism_var(nv1)%ncpl = prism_var(nv1)%ncpl + 1
899  if (prism_var(nv1)%ncpl > mvarcpl) then
900  WRITE(nulprt,*) subname,estr,'ncpl too high, max size (mvarcpl) = ',mvarcpl
901  WRITE(nulprt,*) subname,estr,'increase mvarcpl in mod_oasis_var'
902  call oasis_abort()
903  endif
904  prism_var(nv1)%cpl(prism_var(nv1)%ncpl) = nc
905 
906  !--------------------------------
907  ! prism_coupler settings
908  !> * Copy namcouple settings into this coupler or
909  !> check that coupler is consistent with prior setting
910  !--------------------------------
911 
912  if (pcpointer%valid) then
913  if (pcpointer%comp /= nm) then
914  WRITE(nulprt,*) subname,estr,'mismatch in field comp for var = ',trim(myfld)
915  call oasis_abort()
916  endif
917  if (pcpointer%namID /= nn) then
918  WRITE(nulprt,*) subname,estr,'mismatch in field namID for var = ',trim(myfld)
919  call oasis_abort()
920  endif
921  if (pcpointer%partID /= part1) then
922  WRITE(nulprt,*) subname,estr,'mismatch in field partID for var = ',trim(myfld)
923  call oasis_abort()
924  endif
925 
926  else
927  pcpointer%comp = nm
928  pcpointer%seq = namfldseq(nn)
929  pcpointer%dt = namflddti(nn)
930  pcpointer%lag = namfldlag(nn)
931  pcpointer%maxtime= namruntim
932  pcpointer%rstfile= trim(namrstfil(nn))
933  pcpointer%inpfile= trim(naminpfil(nn))
934  pcpointer%mapperID = -1
935  pcpointer%partID = part1
936  pcpointer%rpartID= part1
937  pcpointer%namID = nn
938  pcpointer%trans = namfldtrn(nn)
939  pcpointer%conserv= namfldcon(nn)
940  pcpointer%consopt= namfldcoo(nn)
941  pcpointer%ops = namfldops(nn)
942  pcpointer%tag = compid*100*1000 + compid*1000 + nn
943  pcpointer%getput = oasis_notdef
944  pcpointer%sndrcv = .false.
945  pcpointer%output = .false.
946  pcpointer%input = .false.
947  pcpointer%sndmult= namfldsmu(nn)
948  pcpointer%sndadd = namfldsad(nn)
949  pcpointer%rcvmult= namflddmu(nn)
950  pcpointer%rcvadd = namflddad(nn)
951  pcpointer%snddiag= namchecki(nn)
952  pcpointer%rcvdiag= namchecko(nn)
953 
954  !--------------------------------
955  !> * Set prism_coupler input and output flags
956  ! prism_coupler comm flags, need for tags to match up on both sides
957  ! tags assume up to 1000 namcouple inputs and 100 models
958  !--------------------------------
959 
960  IF (oasis_debug >= 20) THEN
961  WRITE(nulprt,*) subname,' inout flags '
962  CALL oasis_flush(nulprt)
963  ENDIF
964 
965  if (namfldops(nn) == ip_output .or. namfldops(nn) == ip_expout) then
966  pcpointer%output = .true.
967  pcpointer%getput = oasis3_put
968  endif
969  if (namfldops(nn) == ip_input) then
970  pcpointer%input = .true.
971  pcpointer%getput = oasis3_get
972  endif
973 
974  if (namfldops(nn) == ip_exported .or. namfldops(nn) == ip_expout) then
975  pcpointer%sndrcv = .true.
976  if (flag == oasis_out) then
977  pcpointer%tag = nm*100*1000 + compid*1000 + nn
978  pcpointer%getput = oasis3_put
979  elseif (flag == oasis_in) then
980  pcpointer%tag = compid*100*1000 + nm*1000 + nn
981  pcpointer%getput = oasis3_get
982  endif
983  !--------------------------------
984  !> * Setup prism_coupler router
985  ! cannot reuse router because don't really know what's on the other side
986  ! if router is already set for the coupler, then fine, otherwise, set new router
987  !--------------------------------
988  if (pcpointer%routerID == ispval) then
989  prism_nrouter = prism_nrouter+1
990  if (prism_nrouter > prism_mrouter) then
991  write(nulprt,*) subname,estr,'prism_nrouter too large = ',prism_nrouter,prism_mrouter
992  write(nulprt,*) subname,estr,'check prism_mrouter in oasis_coupler_setup '
993  call oasis_abort()
994  endif
995  pcpointer%routerID = prism_nrouter
996  endif
997  endif
998 
999  !--------------------------------
1000  !> * Setup prism_coupler mapper
1001  !--------------------------------
1002 
1003  IF (oasis_debug >= 20) THEN
1004  WRITE(nulprt,*) subname,' mapper '
1005  CALL oasis_flush(nulprt)
1006  ENDIF
1007 
1008  tmp_mapfile = nammapfil(nn)
1009 
1010  if (trim(tmp_mapfile) == 'idmap' .and. trim(namscrmet(nn)) /= trim(cspval)) then
1011  if (trim(namscrmet(nn)) == 'CONSERV') then
1012  tmp_mapfile = 'rmp_'//trim(namsrcgrd(nn))//'_to_'//trim(namdstgrd(nn))//&
1013  &'_'//trim(namscrmet(nn))//'_'//trim(namscrnor(nn))//'.nc'
1014  else
1015  tmp_mapfile = 'rmp_'//trim(namsrcgrd(nn))//'_to_'//trim(namdstgrd(nn))//&
1016  &'_'//trim(namscrmet(nn))//'.nc'
1017  endif
1018  endif
1019 
1020  if (trim(tmp_mapfile) /= 'idmap') then
1021  pcpointer%maploc = trim(nammaploc(nn))
1022  if ((flag == oasis_in .and. trim(nammaploc(nn)) == 'dst') .or. &
1023  (flag == oasis_out .and. trim(nammaploc(nn)) == 'src')) then
1024  !--------------------------------
1025  !> * Try to reuse mapper already defined,
1026  !> must match mapping file and partition
1027  !--------------------------------
1028  mapid = -1
1029  do n = 1,prism_nmapper
1030  if (trim(prism_mapper(n)%file) == trim(tmp_mapfile) .and. &
1031  trim(prism_mapper(n)%loc ) == trim(nammaploc(nn)) .and. &
1032  trim(prism_mapper(n)%opt ) == trim(nammapopt(nn))) then
1033  if (flag == oasis_in .and. prism_mapper(n)%dpart == part1) mapid = n
1034  if (flag == oasis_out .and. prism_mapper(n)%spart == part1) mapid = n
1035  endif
1036  enddo
1037  !--------------------------------
1038  !> * Or get ready to initialize a new mapper
1039  !--------------------------------
1040  if (mapid < 1) then
1041  prism_nmapper = prism_nmapper + 1
1042  if (prism_nmapper > prism_mmapper) then
1043  write(nulprt,*) subname,estr,'prism_nmapper too large',prism_nmapper,prism_mmapper
1044  write(nulprt,*) subname,estr,'check prism_mmapper in oasis_coupler_setup '
1045  call oasis_abort()
1046  endif
1047  mapid = prism_nmapper
1048  prism_mapper(mapid)%file = trim(tmp_mapfile)
1049  prism_mapper(mapid)%loc = trim(nammaploc(nn))
1050  prism_mapper(mapid)%opt = trim(nammapopt(nn))
1051  if (flag == oasis_in ) prism_mapper(mapid)%dpart = part1
1052  if (flag == oasis_out) prism_mapper(mapid)%spart = part1
1053  if (oasis_debug > 15) then
1054  write(nulprt,*) subname,' DEBUG new mapper for file ',&
1055  trim(prism_mapper(mapid)%file)
1056  call oasis_flush(nulprt)
1057  endif
1058  endif
1059  pcpointer%mapperID = mapid
1060  endif ! flag and nammaploc match
1061  endif ! nammapfil
1062 
1063  pcpointer%valid = .true.
1064 
1065  endif ! valid
1066 
1067  if (local_timers_on) call oasis_timer_stop('cpl_setup_n3d')
1068 
1069  enddo ! nvf
1070 
1071  endif ! my var found
1072 
1073  enddo ! nfind
1074  enddo ! nv1
1075  if (local_timers_on) call oasis_timer_stop('cpl_setup_n3')
1076  if (local_timers_on) call oasis_timer_start('cpl_setup_n4')
1077  if (local_timers_on) call oasis_timer_start('cpl_setup_n4a')
1078 
1079  ! aggregate checkused info across all pes and then check on each component root
1080  allocate(namsrc_checkused_g(sortnsrc%num))
1081  call oasis_mpi_max(namsrc_checkused,namsrc_checkused_g,mpi_comm_global,string=trim(subname)//':srccheckused',all=.true.)
1082  found = .false.
1083  do n1 = 1,sortnsrc%num
1084  if (namsrc_checkused_g(n1) /= 1) then
1085  if (mpi_rank_local == 0) write(nulprt,*) subname,estr,'namcouple variable not used: ',trim(sortnsrc%fld(n1))
1086  found = .true.
1087  endif
1088  enddo
1089 ! call oasis_mpi_barrier(mpi_comm_global)
1090  if (found) call oasis_abort()
1091  deallocate(namsrc_checkused_g)
1092 
1093  !--- deallocate temporary ---
1094  deallocate(allvar,nallvar,allops)
1095  deallocate(namsrc_checkused)
1096  deallocate(sortnsrc%fld)
1097  deallocate(sortnsrc%namnum)
1098  deallocate(sortnsrc%fldnum)
1099  deallocate(sortndst%fld)
1100  deallocate(sortndst%namnum)
1101  deallocate(sortndst%fldnum)
1102  deallocate(sortvars%fld)
1103  deallocate(sortvars%modnum)
1104  deallocate(sortvars%varnum)
1105 
1106  if (oasis_debug >= 20) then
1107  write(nulprt,*) ' '
1108  write(nulprt,*) subname,' couplers setup'
1109  do nc = 1,prism_mcoupler
1110 !tcx can't write here, something uninitialized???
1111 !-> CEG it was dpart so added extra if into the print routine
1112 ! if (prism_coupler_put(nc)%valid) call prism_coupler_print(nc,prism_coupler_put(nc))
1113 ! if (prism_coupler_get(nc)%valid) call prism_coupler_print(nc,prism_coupler_get(nc))
1114  enddo
1115  write(nulprt,*) ' '
1116  call oasis_flush(nulprt)
1117  endif
1118 
1119  if (mpi_comm_local == mpi_comm_null) then
1120  return
1121  endif
1122 
1123  !----------------------------------------------------------
1124  !> * Initialize coupling infrastructure based on initial coupler setup above
1125  !----------------------------------------------------------
1126 
1127  call oasis_debug_note(subname//' initialize coupling datatypes')
1128 
1129  !----------------------------------------------------------
1130  !> * Loop over all couplers
1131  !----------------------------------------------------------
1132 
1133  if (local_timers_on) call oasis_timer_stop('cpl_setup_n4a')
1134 
1135  do nc = 1,prism_mcoupler
1136  do npc = 1,2
1137  if (npc == 1) then
1138  pcpointer => prism_coupler_put(nc)
1139  pcpntpair => prism_coupler_get(nc)
1140  endif
1141  if (npc == 2) then
1142  pcpointer => prism_coupler_get(nc)
1143  pcpntpair => prism_coupler_put(nc)
1144  endif
1145  if (oasis_debug >= 20) then
1146  write(nulprt,*) subname,' DEBUG cb:initialize coupler ',nc,npc,pcpointer%valid
1147  call oasis_flush(nulprt)
1148  endif
1149 
1150  if (pcpointer%valid) then
1151  if (local_timers_on) call oasis_timer_start('cpl_setup_n4b')
1152  if (oasis_debug >= 5) then
1153  write(nulprt,*) subname,' DEBUG ci:initialize coupler ',nc,npc
1154  call oasis_flush(nulprt)
1155  endif
1156 
1157  namid = pcpointer%namID
1158  part1 = pcpointer%partID
1159  mapid = pcpointer%mapperID
1160 
1161  if (part1 <= 0) then
1162  write(nulprt,*) subname,estr,'part1 invalid = ',part1
1163  call oasis_abort()
1164  endif
1165 
1166  !--------------------------------
1167  !> * Initialize avect1 which stores the get/put data
1168  !--------------------------------
1169 
1170  gsize = mct_gsmap_gsize(prism_part(part1)%gsmap)
1171  lsize = mct_gsmap_lsize(prism_part(part1)%gsmap,mpi_comm_local)
1172  if (oasis_debug >= 15) then
1173  write(nulprt,'(1x,2a,5i10)') subname,' DEBUG ci:part1 info ',namid,part1,mapid,gsize,lsize
1174  write(nulprt,'(1x,2a,4i12)') subname,' DEBUG ci:part1a',prism_part(part1)%gsmap%ngseg,&
1175  prism_part(part1)%gsmap%gsize
1176  do n1 = 1,prism_part(part1)%gsmap%ngseg
1177  write(nulprt,'(1x,2a,4i12)') subname,' DEBUG ci:part1b',n1,&
1178  prism_part(part1)%gsmap%start(n1),&
1179  prism_part(part1)%gsmap%length(n1),&
1180  prism_part(part1)%gsmap%pe_loc(n1)
1181  enddo
1182  call oasis_flush(nulprt)
1183  endif
1184  call mct_avect_init(pcpointer%avect1,rlist=trim(pcpointer%fldlist),lsize=lsize)
1185  call mct_avect_zero(pcpointer%avect1)
1186  pcpointer%aVon(1) = .true.
1187  if (oasis_debug >= 15) then
1188  write(nulprt,*) subname,' DEBUG ci:avect1 initialized '
1189  call oasis_flush(nulprt)
1190  endif
1191 
1192  !--------------------------------
1193  !> * Compute nflds for this coupling and initialize avcnt and status
1194  !--------------------------------
1195 
1196  pcpointer%nflds = mct_avect_nrattr(pcpointer%avect1)
1197  allocate(pcpointer%status(pcpointer%nflds))
1198  allocate(pcpointer%avcnt (pcpointer%nflds))
1199  pcpointer%avcnt(:) = 0
1200  if (pcpointer%getput == oasis3_put) pcpointer%status = oasis_comm_wait
1201  if (pcpointer%getput == oasis3_get) pcpointer%status = oasis_comm_ready
1202  if (local_timers_on) call oasis_timer_stop('cpl_setup_n4b')
1203 
1204  !--------------------------------
1205  !> * Initialize the mapper data
1206  !--------------------------------
1207 
1208  if (mapid > 0) then
1209 
1210  if (prism_mapper(mapid)%init) then
1211  if (local_timers_on) call oasis_timer_start('cpl_setup_n4c')
1212  !--------------------------------
1213  ! mapper already initialized
1214  !--------------------------------
1215  if (pcpointer%getput == oasis3_put) then
1216  part2 = prism_mapper(mapid)%dpart
1217  else
1218  part2 = prism_mapper(mapid)%spart
1219  endif
1220  gsize = mct_gsmap_gsize(prism_part(part2)%gsmap)
1221  if (local_timers_on) call oasis_timer_stop('cpl_setup_n4c')
1222  else
1223  !--------------------------------
1224  ! instantiate mapper
1225  ! read/generate mapping file
1226  ! read non local grid size
1227  ! get gsmap for non local grid
1228  ! read mapping weights and initialize sMatP
1229  !--------------------------------
1230  if (local_timers_on) call oasis_timer_start('cpl_setup_n4d')
1231  if (oasis_debug >= 15) then
1232  write(nulprt,*) subname,' DEBUG ci:read mapfile ',trim(prism_mapper(mapid)%file)
1233  call oasis_flush(nulprt)
1234  endif
1235  if (mpi_rank_local == 0) then
1236  if (local_timers_on) call oasis_timer_start('cpl_setup_n4da')
1237  if (local_timers_on) call oasis_timer_start('cpl_setup_n4da1')
1238  inquire(file=trim(prism_mapper(mapid)%file),exist=exists)
1239  if (local_timers_on) call oasis_timer_stop('cpl_setup_n4da1')
1240  if (oasis_debug >= 15) then
1241  write(nulprt,*) subname,' DEBUG ci: inquire mapfile ',&
1242  trim(prism_mapper(mapid)%file),exists
1243  call oasis_flush(nulprt)
1244  endif
1245  if (.not.exists) then
1246  if (trim(namscrmet(namid)) /= trim(cspval)) then
1247  !--------------------------------
1248  ! generate mapping file on root pe
1249  ! taken from oasis3 scriprmp
1250  !--------------------------------
1251  call oasis_timer_start('cpl_setup_genmap')
1252  call oasis_map_genmap(mapid,namid)
1253  call oasis_timer_stop('cpl_setup_genmap')
1254  else
1255  write(nulprt,*) subname,estr,'map file does not exist and SCRIPR not set = ',&
1256  trim(prism_mapper(mapid)%file)
1257  call oasis_abort()
1258  endif
1259  endif
1260 
1261  !--------------------------------
1262  ! open mapping file
1263  !--------------------------------
1264  if (local_timers_on) call oasis_timer_start('cpl_setup_n4da3')
1265  status = nf90_open(trim(prism_mapper(mapid)%file),nf90_nowrite,ncid)
1266  if (oasis_debug >= 15) then
1267  status = nf90_inq_dimid(ncid,'dst_grid_size',dimid)
1268  status = nf90_inquire_dimension(ncid,dimid,len=gsize)
1269  write(nulprt,*) subname," DEBUG dst_grid_size ",gsize
1270  status = nf90_inq_dimid(ncid,'src_grid_size',dimid)
1271  status = nf90_inquire_dimension(ncid,dimid,len=gsize)
1272  write(nulprt,*) subname," DEBUG src_grid_size ",gsize
1273  endif
1274  if (pcpointer%getput == oasis3_put) &
1275  status = nf90_inq_dimid(ncid,'dst_grid_size',dimid)
1276  if (pcpointer%getput == oasis3_get) &
1277  status = nf90_inq_dimid(ncid,'src_grid_size',dimid)
1278  status = nf90_inquire_dimension(ncid,dimid,len=gsize)
1279  if (local_timers_on) call oasis_timer_stop('cpl_setup_n4da3')
1280  if (local_timers_on) call oasis_timer_stop('cpl_setup_n4da')
1281  endif ! rank = 0
1282  if (local_timers_on) call oasis_timer_start('cpl_setup_n4db')
1283  call oasis_mpi_bcast(gsize,mpi_comm_local,subname//' gsize')
1284  if (local_timers_on) call oasis_timer_stop('cpl_setup_n4db')
1285 
1286  if (local_timers_on) call oasis_timer_start('cpl_setup_n4dc')
1287  if (pcpointer%getput == oasis3_put) then
1288  nx = namdst_nx(namid)
1289  ny = namdst_ny(namid)
1290  gridname = trim(namdstgrd(namid))
1291  else
1292  nx = namsrc_nx(namid)
1293  ny = namsrc_ny(namid)
1294  gridname = trim(namsrcgrd(namid))
1295  endif
1296  if (local_timers_on) call oasis_timer_stop('cpl_setup_n4dc')
1297 
1298  !tcx improve match here with nx,ny,gridname
1299  if (local_timers_on) call oasis_timer_start('cpl_setup_n4dd')
1300  call oasis_part_create(part2,'1d',gsize,nx,ny,gridname,prism_part(part1)%mpicom,mpi_comm_local)
1301  if (local_timers_on) call oasis_timer_stop('cpl_setup_n4dd')
1302 
1303  if (oasis_debug >= 15) then
1304  write(nulprt,*) subname," DEBUG part_create part1 gsize",prism_part(part1)%gsize
1305  do r1 = 1,prism_part(part1)%gsmap%ngseg
1306  write(nulprt,*) subname," DEBUG part_create part1 info ",&
1307  prism_part(part1)%gsmap%start(r1),prism_part(part1)%gsmap%length(r1),&
1308  prism_part(part1)%gsmap%pe_loc(r1)
1309  enddo
1310 
1311  write(nulprt,*) subname," DEBUG part_create part2 gsize",prism_part(part2)%gsize
1312  do r1 = 1,prism_part(part2)%gsmap%ngseg
1313  write(nulprt,*) subname," DEBUG part_create part2 info ",prism_part(part2)%gsmap%start(r1),&
1314  prism_part(part2)%gsmap%length(r1),prism_part(part2)%gsmap%pe_loc(r1)
1315  enddo
1316  endif
1317 
1318  if (local_timers_on) call oasis_timer_start('cpl_setup_n4de')
1319  if (prism_part(part2)%nx < 1) then
1320  prism_part(part2)%nx = nx
1321  prism_part(part2)%ny = ny
1322  prism_part(part2)%gridname = trim(gridname)
1323  endif
1324 
1325  if (pcpointer%getput == oasis3_put) then
1326  !prism_mapper(mapID)%spart = part1 ! set above
1327  prism_mapper(mapid)%dpart = part2
1328  else
1329  prism_mapper(mapid)%spart = part2
1330  !prism_mapper(mapID)%dpart = part1 ! set above
1331  endif
1332  spart = prism_mapper(mapid)%spart
1333  dpart = prism_mapper(mapid)%dpart
1334 
1335  !--- cstring sets whether src or dst are rearranged in remap
1336  !--- src = rearrange and map (bfb), dst = map and rearrange (partial sum)
1337  if (prism_mapper(mapid)%opt == 'opt') then
1338  if (prism_part(spart)%gsize > prism_part(dpart)%gsize) then
1339  cstring = 'dst'
1340  else
1341  cstring = 'src'
1342  endif
1343  elseif (prism_mapper(mapid)%opt == 'bfb') then
1344  cstring = 'src'
1345  elseif (prism_mapper(mapid)%opt == 'sum') then
1346  cstring = 'dst'
1347  else
1348  write(nulprt,*) subname,estr,'mapper opt invalid expect bfb or sum =',trim(prism_mapper(mapid)%opt)
1349  call oasis_abort()
1350  endif
1351  if (prism_mapper(mapid)%optval /= '' .and. &
1352  prism_mapper(mapid)%optval /= trim(cstring)) then
1353  write(nulprt,*) subname,estr,'mapper opt changed',&
1354  trim(prism_mapper(mapid)%optval),' ',trim(cstring)
1355  call oasis_abort()
1356  endif
1357  prism_mapper(mapid)%optval = trim(cstring)
1358  if (local_timers_on) call oasis_timer_stop('cpl_setup_n4de')
1359  if (local_timers_on) call oasis_timer_stop('cpl_setup_n4d')
1360 
1361  !-------------------------------
1362  ! smatreaddnc allocates sMati to nwgts
1363  ! then instantiate an sMatP for each set of wgts
1364  ! to support higher order mapping
1365  !-------------------------------
1366  if (smatread_method == "ceg") then
1367  call oasis_timer_start('smatrd_ceg')
1368  call oasis_map_smatreaddnc_ceg(smati,prism_part(spart)%gsmap,prism_part(dpart)%gsmap, &
1369  trim(cstring),trim(prism_mapper(mapid)%file),mpi_rank_local,mpi_comm_local,nwgts)
1370  call oasis_timer_stop('smatrd_ceg')
1371  else
1372  call oasis_timer_start('smatrd_orig')
1373  call oasis_map_smatreaddnc_orig(smati,prism_part(spart)%gsmap,prism_part(dpart)%gsmap, &
1374  trim(cstring),trim(prism_mapper(mapid)%file),mpi_rank_local,mpi_comm_local,nwgts)
1375  call oasis_timer_stop('smatrd_orig')
1376  endif
1377  if (local_timers_on) call oasis_timer_start('cpl_setup_sminit')
1378  prism_mapper(mapid)%nwgts = nwgts
1379  allocate(prism_mapper(mapid)%sMatP(nwgts))
1380  do n = 1,nwgts
1381  call mct_smatp_init(prism_mapper(mapid)%sMatP(n), smati(n), &
1382  prism_part(spart)%gsmap, prism_part(dpart)%gsmap, 0, mpi_comm_local, compid)
1383  call mct_smat_clean(smati(n))
1384  enddo
1385  deallocate(smati)
1386  if (local_timers_on) call oasis_timer_stop('cpl_setup_sminit')
1387  if (local_timers_on) call oasis_timer_start('cpl_setup_n4e')
1388 
1389  lsize = mct_smat_gnumel(prism_mapper(mapid)%sMatP(1)%Matrix,mpi_comm_local)
1390  prism_mapper(mapid)%init = .true.
1391  if (oasis_debug >= 15) then
1392  write(nulprt,*) subname," DEBUG ci:done initializing prism_mapper",mapid,&
1393  " nElements = ",lsize," nwgts = ",nwgts
1394  call oasis_flush(nulprt)
1395  endif
1396  if (local_timers_on) call oasis_timer_stop('cpl_setup_n4e')
1397  endif ! map init
1398 
1399  if (local_timers_on) call oasis_timer_start('cpl_setup_n4f')
1400  !--------------------------------
1401  !> * Read mapper mask and area if not already done
1402  !--------------------------------
1403  if (.not.prism_mapper(mapid)%AVred .and. pcpointer%conserv /= ip_cnone) then
1404  ! initialize and load AV_ms and AV_md
1405 
1406  spart = prism_mapper(mapid)%spart
1407  dpart = prism_mapper(mapid)%dpart
1408 
1409  lsize = mct_gsmap_lsize(prism_part(spart)%gsmap,mpi_comm_local)
1410  call mct_avect_init(prism_mapper(mapid)%av_ms,ilist='mask',rlist='area',lsize=lsize)
1411  call mct_avect_zero(prism_mapper(mapid)%av_ms)
1412  gridname = prism_part(spart)%gridname
1413  call oasis_io_read_avfld('masks.nc',prism_mapper(mapid)%av_ms, &
1414  prism_part(spart)%gsmap,mpi_comm_local,'mask',trim(gridname)//'.msk',fldtype='int')
1415  call oasis_io_read_avfld('areas.nc',prism_mapper(mapid)%av_ms, &
1416  prism_part(spart)%gsmap,mpi_comm_local,'area',trim(gridname)//'.srf',fldtype='real')
1417 
1418  lsize = mct_gsmap_lsize(prism_part(dpart)%gsmap,mpi_comm_local)
1419  call mct_avect_init(prism_mapper(mapid)%av_md,ilist='mask',rlist='area',lsize=lsize)
1420  call mct_avect_zero(prism_mapper(mapid)%av_md)
1421  gridname = prism_part(dpart)%gridname
1422  call oasis_io_read_avfld('masks.nc',prism_mapper(mapid)%av_md, &
1423  prism_part(dpart)%gsmap,mpi_comm_local,'mask',trim(gridname)//'.msk',fldtype='int')
1424  call oasis_io_read_avfld('areas.nc',prism_mapper(mapid)%av_md, &
1425  prism_part(dpart)%gsmap,mpi_comm_local,'area',trim(gridname)//'.srf',fldtype='real')
1426 
1427  prism_mapper(mapid)%AVred = .true.
1428 
1429  if (oasis_debug >= 30) then
1430  write(nulprt,*) subname,' DEBUG msi ',minval(prism_mapper(mapid)%av_ms%iAttr(:,:)),&
1431  maxval(prism_mapper(mapid)%av_ms%iAttr(:,:)),&
1432  sum(prism_mapper(mapid)%av_ms%iAttr(:,:))
1433  write(nulprt,*) subname,' DEBIG msr ',minval(prism_mapper(mapid)%av_ms%rAttr(:,:)),&
1434  maxval(prism_mapper(mapid)%av_ms%rAttr(:,:)),&
1435  sum(prism_mapper(mapid)%av_ms%rAttr(:,:))
1436  write(nulprt,*) subname,' DEBUG mdi ',minval(prism_mapper(mapid)%av_md%iAttr(:,:)),&
1437  maxval(prism_mapper(mapid)%av_md%iAttr(:,:)),&
1438  sum(prism_mapper(mapid)%av_md%iAttr(:,:))
1439  write(nulprt,*) subname,' DEBUG mdr ',minval(prism_mapper(mapid)%av_md%rAttr(:,:)),&
1440  maxval(prism_mapper(mapid)%av_md%rAttr(:,:)),&
1441  sum(prism_mapper(mapid)%av_md%rAttr(:,:))
1442  CALL oasis_flush(nulprt)
1443  endif
1444  endif
1445 
1446  !--------------------------------
1447  !> * Initialize avect1m, the data in avect1 mapped to another grid
1448  !--------------------------------
1449 
1450  lsize = mct_gsmap_lsize(prism_part(part2)%gsmap,mpi_comm_local)
1451  if (oasis_debug >= 15) then
1452  write(nulprt,'(1x,2a,4i12)') subname,' DEBUG ci:part2 info ',part2,mapid,gsize,lsize
1453  write(nulprt,'(1x,2a,4i12)') subname,' DEBUG ci:part2a',prism_part(part2)%gsmap%ngseg,&
1454  prism_part(part2)%gsmap%gsize
1455  do n1 = 1,prism_part(part2)%gsmap%ngseg
1456  write(nulprt,'(1x,2a,4i12)') subname,' DEBUG ci:part2b',n1,prism_part(part2)%gsmap%start(n1),&
1457  prism_part(part2)%gsmap%length(n1),prism_part(part2)%gsmap%pe_loc(n1)
1458  enddo
1459  call oasis_flush(nulprt)
1460  endif
1461  call mct_avect_init(pcpointer%avect1m,rlist=trim(pcpointer%fldlist),lsize=lsize)
1462  call mct_avect_zero(pcpointer%avect1m)
1463  if (oasis_debug >= 15) then
1464  write(nulprt,*) subname,' DEBUG ci:avect1m initialized '
1465  call oasis_flush(nulprt)
1466  endif
1467 
1468  !--------------------------------
1469  ! router partition is always other part
1470  !--------------------------------
1471 
1472  pcpointer%rpartID = part2
1473  if (local_timers_on) call oasis_timer_stop('cpl_setup_n4f')
1474  else
1475 
1476  !--------------------------------
1477  ! router partition is just coupler part
1478  ! Set to this by default above
1479  !--------------------------------
1480 
1481  ! pcpointer%rpartID = pcpointer%partID
1482 
1483  endif ! no mapper
1484 
1485  endif ! endif of pcpointer%valid
1486 
1487 ! print'(I3,A,X,L,X,8(I8,X))',mpi_rank_global, 'would have done sndrcv here', pcpointer%sndrcv,pcpointer%comp,compid, &
1488 ! pcpointer%valid, mapID, pcpointer%rPartID, pcpointer%routerID
1489 
1490  enddo ! npc
1491  enddo ! nc
1492 
1493 !-------------------------------------------------
1494 ! CEG split 1 loop into 2 to allow map reading on different models in parallel.
1495 !-------------------------------------------------
1496 
1497  do nc = 1, prism_mcoupler ! nc
1498  do npc=1,2
1499 
1500  if (npc == 1) then
1501  pcpointer => prism_coupler_put(nc)
1502  pcpntpair => prism_coupler_get(nc)
1503  endif
1504  if (npc == 2) then
1505  pcpointer => prism_coupler_get(nc)
1506  pcpntpair => prism_coupler_put(nc)
1507  endif
1508 
1509  namid = pcpointer%namID
1510  part1 = pcpointer%partID
1511  mapid = pcpointer%mapperID
1512 
1513 ! print'(I3,A,X,L,X,8(I8,X))',mpi_rank_global, '..finally doing sndrcv here', pcpointer%sndrcv, pcpointer%comp, compid, &
1514 ! pcpointer%valid, mapID, pcpointer%rPartID, pcpointer%routerID
1515 ! if (mapID > 0) then
1516 
1517  !--------------------------------
1518  !> * Initialize router based on rpartID
1519  !--------------------------------
1520 
1521  if (local_timers_on) call oasis_timer_start('cpl_setup_n4_sr')
1522  if (pcpointer%sndrcv) then
1523 
1524  if (oasis_debug >= 15) then
1525  write(nulprt,*) subname,' DEBUG ci:initialize router ',pcpointer%routerID,&
1526  pcpointer%comp,pcpointer%rpartID
1527  call oasis_flush(nulprt)
1528  endif
1529 
1530  if (compid == pcpointer%comp) then
1531  ! routers for sending to self
1532  ! setup router on second pass so rpartID is defined on both sides
1533  ! setup both routers at the same time
1534  if (local_timers_on) call oasis_timer_start('cpl_setup_n4_sra')
1535  if (npc == 2) then
1536  if (oasis_debug >= 15) then
1537  write(nulprt,*) subname,' DEBUG self router between part ',pcpointer%rpartID,' and part ',pcpntpair%rpartID, &
1538  ' with router ',pcpointer%routerID,' and router ',pcpntpair%routerID,' for compid ',compid
1539  endif
1540  call mct_router_init(prism_part(pcpointer%rpartID)%gsmap, prism_part(pcpntpair%rpartID)%gsmap, &
1541  mpi_comm_local, prism_router(pcpointer%routerID)%router)
1542  call mct_router_init(prism_part(pcpntpair%rpartID)%gsmap, prism_part(pcpointer%rpartID)%gsmap, &
1543  mpi_comm_local, prism_router(pcpntpair%routerID)%router)
1544 
1545  if (oasis_debug >= 15) then
1546  write(nulprt,*) subname," DEBUG ci:done initializing prism_router",&
1547  pcpointer%routerID
1548  if (oasis_debug >= 20) then
1549  do r1 = 1,prism_part(pcpointer%rpartID)%gsmap%ngseg
1550  write(nulprt,*) subname," DEBUG router gs1 info ",prism_part(pcpointer%rpartID)%gsmap%start(r1),&
1551  prism_part(pcpointer%rpartID)%gsmap%length(r1),prism_part(pcpointer%rpartID)%gsmap%pe_loc(r1)
1552  enddo
1553  do r1 = 1,prism_part(pcpointer%partID)%gsmap%ngseg
1554  write(nulprt,*) subname," DEBUG router gs2 info ",prism_part(pcpointer%partID)%gsmap%start(r1),&
1555  prism_part(pcpointer%partID)%gsmap%length(r1),prism_part(pcpointer%partID)%gsmap%pe_loc(r1)
1556  enddo
1557  do r1 = 1,prism_part(pcpntpair%rpartID)%gsmap%ngseg
1558  write(nulprt,*) subname," DEBUG router gs3 info ",prism_part(pcpntpair%rpartID)%gsmap%start(r1),&
1559  prism_part(pcpntpair%rpartID)%gsmap%length(r1),prism_part(pcpntpair%rpartID)%gsmap%pe_loc(r1)
1560  enddo
1561  do r1 = 1,prism_part(pcpntpair%partid)%gsmap%ngseg
1562  write(nulprt,*) subname," DEBUG router gs4 info ",prism_part(pcpntpair%partid)%gsmap%start(r1),&
1563  prism_part(pcpntpair%partid)%gsmap%length(r1),prism_part(pcpntpair%partid)%gsmap%pe_loc(r1)
1564  enddo
1565  do r1 = 1,prism_router(pcpointer%routerID)%router%nprocs
1566  write(nulprt,*) subname," DEBUG router info ",pcpointer%routerID,r1, &
1567  prism_router(pcpointer%routerID)%router%pe_list(r1),prism_router(pcpointer%routerID)%router%locsize(r1)
1568  enddo
1569  endif
1570  call oasis_flush(nulprt)
1571  endif
1572 
1573  if (oasis_debug >= 15) then
1574  write(nulprt,*) subname," DEBUG ci:done initializing prism_router",&
1575  pcpntpair%routerID
1576  if (oasis_debug >= 20) then
1577  do r1 = 1,prism_router(pcpntpair%routerID)%router%nprocs
1578  write(nulprt,*) subname," DEBUG router info ",pcpntpair%routerID,r1, &
1579  prism_router(pcpntpair%routerID)%router%pe_list(r1),prism_router(pcpntpair%routerID)%router%locsize(r1)
1580  enddo
1581  endif
1582  call oasis_flush(nulprt)
1583  endif
1584  endif
1585 
1586  if (local_timers_on) call oasis_timer_stop('cpl_setup_n4_sra')
1587  else
1588  if (local_timers_on) call oasis_timer_start('cpl_setup_n4_srb')
1589 
1590  call mct_router_init(pcpointer%comp,prism_part(pcpointer%rpartID)%gsmap, &
1591  mpi_comm_local,prism_router(pcpointer%routerID)%router)
1592 
1593  if (oasis_debug >= 15) then
1594  write(nulprt,*) subname," DEBUG ci:done initializing prism_router",&
1595  pcpointer%routerID
1596  if (oasis_debug >= 20) then
1597  do r1 = 1,prism_router(pcpointer%routerID)%router%nprocs
1598  write(nulprt,*) subname," DEBUG router info ",pcpointer%routerID,r1, &
1599  prism_router(pcpointer%routerID)%router%pe_list(r1),prism_router(pcpointer%routerID)%router%locsize(r1)
1600  enddo
1601  endif
1602  call oasis_flush(nulprt)
1603  endif
1604  if (local_timers_on) call oasis_timer_stop('cpl_setup_n4_srb')
1605 
1606  endif
1607 
1608  endif
1609  if (local_timers_on) call oasis_timer_stop('cpl_setup_n4_sr')
1610 
1611  enddo ! npc
1612  enddo ! prism_mcoupler
1613 
1614  if (local_timers_on) call oasis_timer_start('cpl_setup_n4g')
1615  !----------------------------------------------------------
1616  !> * Diagnostics for all couplers
1617  !----------------------------------------------------------
1618 
1619  if (oasis_debug >= 2) then
1620  write(nulprt,*) ' '
1621  write(nulprt,*) subname,' couplers initialized'
1622  do nc = 1,prism_mcoupler
1623  if (prism_coupler_put(nc)%valid) call oasis_coupler_print(nc,prism_coupler_put(nc))
1624  if (prism_coupler_get(nc)%valid) call oasis_coupler_print(nc,prism_coupler_get(nc))
1625  enddo
1626  write(nulprt,*) ' '
1627  CALL oasis_flush(nulprt)
1628  endif
1629 
1630  IF (lucia_debug > 0) THEN
1631  DO nc = 1, prism_mcoupler
1632  IF (prism_coupler_put(nc)%valid) &
1633  WRITE(nullucia, '(A12,I4.4,1X,A)') 'Balance: SN ', prism_coupler_put(nc)%namID, trim(prism_coupler_put(nc)%fldlist)
1634  IF (prism_coupler_get(nc)%valid) &
1635  WRITE(nullucia, '(A12,I4.4,1X,A)') 'Balance: RC ', prism_coupler_get(nc)%namID, trim(prism_coupler_get(nc)%fldlist)
1636  ENDDO
1637  ENDIF
1638 
1639  if (local_timers_on) call oasis_timer_stop('cpl_setup_n4g')
1640  if (local_timers_on) call oasis_timer_stop('cpl_setup_n4')
1641  call oasis_timer_stop('cpl_setup')
1642 
1643  call oasis_debug_exit(subname)
1644 
1645  END SUBROUTINE oasis_coupler_setup
1646 
1647 !------------------------------------------------------------
1648 
1649 !> Print routine for oasis_couplers
1650 
1651  SUBROUTINE oasis_coupler_print(cplid,pcprint)
1652 
1653  IMPLICIT NONE
1654 
1655  integer(ip_i4_p), intent(in) :: cplid !< coupler id
1656  type(prism_coupler_type), intent(in) :: pcprint !< specific prism_coupler
1657  !----------------------------------------------------------
1658  integer(ip_i4_p) :: mapid, rouid, parid, namid, nflds, rpard
1659  integer(ip_i4_p) :: spart,dpart
1660  character(len=*),parameter :: subname = '(oasis_coupler_print)'
1661 
1662  call oasis_debug_enter(subname)
1663 
1664  mapid = pcprint%mapperid
1665  rouid = pcprint%routerid
1666  parid = pcprint%partid
1667  rpard = pcprint%rpartid
1668  namid = pcprint%namid
1669  nflds = pcprint%nflds
1670 
1671  write(nulprt,*) ' '
1672  write(nulprt,*) subname,' model and cplid',compid,cplid
1673  if (pcprint%getput == oasis3_put) then
1674  write(nulprt,*) subname,' send fields ',trim(pcprint%fldlist)
1675  write(nulprt,*) subname,' from model ',compid
1676  write(nulprt,*) subname,' to model ',pcprint%comp
1677  write(nulprt,*) subname,' using router ',rouid
1678  write(nulprt,*) subname,' transform ',pcprint%trans
1679  write(nulprt,*) subname,' snd diagnose ',pcprint%snddiag
1680  write(nulprt,*) subname,' snd fld mult ',pcprint%sndmult
1681  write(nulprt,*) subname,' snd fld add ',pcprint%sndadd
1682  endif
1683  if (pcprint%getput == oasis3_get) then
1684  write(nulprt,*) subname,' recv fields ',trim(pcprint%fldlist)
1685  write(nulprt,*) subname,' from model ',pcprint%comp
1686  write(nulprt,*) subname,' to model ',compid
1687  write(nulprt,*) subname,' using router ',rouid
1688  write(nulprt,*) subname,' rcv diagnose ',pcprint%rcvdiag
1689  write(nulprt,*) subname,' rcv fld mult ',pcprint%rcvmult
1690  write(nulprt,*) subname,' rcv fld add ',pcprint%rcvadd
1691  endif
1692  write(nulprt,*) subname,' namcouple op ',pcprint%ops
1693  write(nulprt,*) subname,' valid ',pcprint%valid
1694  write(nulprt,*) subname,' namcouple id ',namid
1695  write(nulprt,*) subname,' variable ids ',pcprint%varid(1:nflds)
1696  write(nulprt,*) subname,' sndrcv flag ',pcprint%sndrcv
1697  write(nulprt,*) subname,' output flag ',pcprint%output
1698  write(nulprt,*) subname,' input flag ',pcprint%input
1699  write(nulprt,*) subname,' input file ',trim(pcprint%inpfile)
1700  write(nulprt,*) subname,' restart file ',trim(pcprint%rstfile)
1701  write(nulprt,*) subname,' tag ',pcprint%tag
1702  write(nulprt,*) subname,' seq ',pcprint%seq
1703  write(nulprt,*) subname,' maxtime ',pcprint%maxtime
1704  write(nulprt,*) subname,' dt, lag ',pcprint%dt,pcprint%lag
1705  write(nulprt,*) subname,' partid, size ',parid,trim(prism_part(parid)%gridname),&
1706  prism_part(parid)%gsize
1707  write(nulprt,*) subname,' partid, nx,ny',prism_part(parid)%nx,prism_part(parid)%ny
1708  write(nulprt,*) subname,' rpartid,size ',rpard,trim(prism_part(rpard)%gridname),&
1709  prism_part(rpard)%gsize
1710  write(nulprt,*) subname,' rpartid,nx,ny',prism_part(rpard)%nx,prism_part(rpard)%ny
1711  write(nulprt,*) subname,' maploc ',trim(pcprint%maploc)
1712 
1713  if (mapid > 0) then
1714  write(nulprt,*) subname,' use map ',mapid,trim(prism_mapper(mapid)%file)
1715  write(nulprt,*) subname,' nwgts ',mapid,prism_mapper(mapid)%nwgts
1716  spart = prism_mapper(mapid)%spart
1717  dpart = prism_mapper(mapid)%dpart
1718  write(nulprt,*) subname,' conserve ',pcprint%conserv
1719  write(nulprt,*) subname,' conserve opt ',pcprint%consopt
1720  write(nulprt,*) subname,' location ',trim(prism_mapper(mapid)%loc)
1721  write(nulprt,*) subname,' opt,optval ',trim(prism_mapper(mapid)%opt),' ',&
1722  trim(prism_mapper(mapid)%optval)
1723  write(nulprt,*) subname,' s/d partids ',spart,dpart
1724  if (spart > 0) &
1725  write(nulprt,*) subname,' from/to ',trim(prism_part(spart)%gridname),' ',&
1726  trim(prism_part(dpart)%gridname)
1727  write(nulprt,*) subname,' from nx,ny ',prism_part(spart)%gsize,prism_part(spart)%nx,&
1728  prism_part(spart)%ny
1729  if (dpart > 0) &
1730  write(nulprt,*) subname,' to nx,ny ',prism_part(dpart)%gsize, prism_part(dpart)%nx,&
1731  prism_part(dpart)%ny
1732  endif ! mapid > 0
1733 
1734  call oasis_flush(nulprt)
1735 
1736  call oasis_debug_exit(subname)
1737 
1738  END SUBROUTINE oasis_coupler_print
1739 
1740 !------------------------------------------------------------
1741 ! !BOP ===========================================================================
1742 !
1743 !> Sort a character array using a sort key.
1744 !
1745 ! !DESCRIPTION:
1746 ! Sort a character array and the associated array(s) based on a
1747 ! reasonably fast sort algorithm
1748 !
1749 ! !INTERFACE: -----------------------------------------------------------------
1750 
1751 subroutine cplsort(num, fld, sortkey)
1752 
1753 ! !USES:
1754 
1755  !--- local kinds ---
1756  integer,parameter :: R8 = ip_double_p
1757  integer,parameter :: IN = ip_i4_p
1758  integer,parameter :: CL = ic_lvar
1759 
1760 ! !INPUT/OUTPUT PARAMETERS:
1761 
1762  integer(IN), intent(in) :: num !< size of array
1763  character(len=CL),intent(inout) :: fld(:) !< sort field
1764  integer(IN) ,intent(inout) :: sortkey(:) !< sortkey
1765 
1766 ! !EOP
1767 
1768  !--- local ---
1769  integer(IN) :: n1,n2
1770  logical :: stopnow
1771  character(CL), pointer :: tmpfld(:)
1772  integer(IN) , pointer :: tmpkey(:)
1773 
1774  !--- formats ---
1775  character(*),parameter :: subName = '(cplsort) '
1776 
1777 !-------------------------------------------------------------------------------
1778 !
1779 !-------------------------------------------------------------------------------
1780 
1781 ! call oasis_debug_enter(subname)
1782 
1783  allocate(tmpfld((num+1)/2))
1784  allocate(tmpkey((num+1)/2))
1785  call mergesort(num,fld,tmpfld,sortkey,tmpkey)
1786  deallocate(tmpfld)
1787  deallocate(tmpkey)
1788 
1789 ! call oasis_debug_exit(subname)
1790 
1791 end subroutine cplsort
1792 
1793 !------------------------------------------------------------
1794 ! !BOP ===========================================================================
1795 !
1796 !> Sort an integer array using a sort key.
1797 !
1798 ! !DESCRIPTION:
1799 ! Rearrange and integer array based on an input sortkey
1800 !
1801 ! !INTERFACE: -----------------------------------------------------------------
1802 
1803 subroutine cplsortkey(num, arr, sortkey)
1804 
1805 ! !USES:
1806 
1807  !--- local kinds ---
1808  integer,parameter :: R8 = ip_double_p
1809  integer,parameter :: IN = ip_i4_p
1810  integer,parameter :: CL = ic_lvar
1811 
1812 ! !INPUT/OUTPUT PARAMETERS:
1813 
1814  integer(IN),intent(in) :: num !< size of array
1815  integer(IN),intent(inout) :: arr(:) !< field to sort
1816  integer(IN),intent(in) :: sortkey(:) !< sortkey
1817 
1818 ! !EOP
1819 
1820  !--- local ---
1821  integer(IN) :: n1,n2
1822  integer(IN), pointer :: tmparr(:)
1823 
1824  !--- formats ---
1825  character(*),parameter :: subName = '(cplsortkey) '
1826 
1827 !-------------------------------------------------------------------------------
1828 !
1829 !-------------------------------------------------------------------------------
1830 
1831 ! call oasis_debug_enter(subname)
1832 
1833  if (num /= size(arr) .or. num /= size(sortkey)) then
1834  WRITE(nulprt,*) subname,estr,'on size of input arrays :',num,size(arr),size(sortkey)
1835  call oasis_abort()
1836  endif
1837 
1838  allocate(tmparr(num))
1839  tmparr(1:num) = arr(1:num)
1840  do n1 = 1,num
1841  arr(n1) = tmparr(sortkey(n1))
1842  enddo
1843  deallocate(tmparr)
1844 
1845 ! call oasis_debug_exit(subname)
1846 
1847 end subroutine cplsortkey
1848 
1849 !------------------------------------------------------------
1850 ! !BOP ===========================================================================
1851 !
1852 !> Search a character field list for a matching values
1853 !
1854 ! !DESCRIPTION:
1855 ! Sort a character array and the associated array(s) based on a
1856 ! reasonably fast sort algorithm
1857 !
1858 ! !INTERFACE: -----------------------------------------------------------------
1859 
1860 subroutine cplfind(num, fldlist, fld, ifind, nfind)
1861 
1862 ! !USES:
1863 
1864  !--- local kinds ---
1865  integer,parameter :: R8 = ip_double_p
1866  integer,parameter :: IN = ip_i4_p
1867  integer,parameter :: CL = ic_lvar
1868 
1869 ! !INPUT/OUTPUT PARAMETERS:
1870 
1871  integer(IN), intent(in) :: num !< size of array
1872  character(len=CL),intent(in) :: fldlist(:) !< sorted field list
1873  character(len=CL),intent(in) :: fld !< field to search for
1874  integer(IN) ,intent(out) :: ifind !< first match index
1875  integer(IN) ,intent(out) :: nfind !< number that match
1876 
1877 ! !EOP
1878 
1879  !--- local ---
1880  integer(IN) :: is,ie,im
1881  logical :: found
1882 
1883  !--- formats ---
1884  character(*),parameter :: subName = '(cplfind) '
1885 
1886 !-------------------------------------------------------------------------------
1887 !
1888 !-------------------------------------------------------------------------------
1889 
1890 ! call oasis_debug_enter(subname)
1891 
1892  ifind = 0
1893  nfind = 0
1894 
1895  is = 1
1896  ie = num
1897  found = .false.
1898 
1899  ! check endpoints first, the binary search uses integer
1900  ! math which makes hitting the endpoints more difficult
1901  ! so check manually. also if list size is 1, need to do this.
1902 
1903  if (.not.found) then
1904  im = 1
1905  if (fld == fldlist(im)) found = .true.
1906  endif
1907  if (.not.found) then
1908  im = num
1909  if (fld == fldlist(im)) found = .true.
1910  endif
1911 
1912  ! do a binary search
1913 
1914  do while (.not.found .and. ie > is)
1915  im = (is + ie) / 2
1916  im = max(im,is)
1917  im = min(im,ie)
1918 ! write(nulprt,*) subname,'tcx',is,ie,im,trim(fld),' ',trim(fldlist(im))
1919  if (fld == fldlist(im)) then
1920  found = .true.
1921  elseif (fld > fldlist(im)) then
1922  is = max(im,is+1)
1923  else
1924  ie = min(im,ie-1)
1925  endif
1926  enddo
1927 
1928  ! if a match was found, find first and last instance of match in list
1929 
1930  if (found) then
1931  is = im
1932  ie = im
1933  if (is > 1) then
1934  do while (fld == fldlist(is-1) .and. is > 1)
1935  is = is - 1
1936  enddo
1937  endif
1938  if (ie < num) then
1939  do while (fld == fldlist(ie+1) .and. ie < num)
1940  ie = ie + 1
1941  enddo
1942  endif
1943  ifind = is
1944  nfind = (ie - is + 1)
1945  endif
1946 
1947 ! call oasis_debug_exit(subname)
1948 
1949 end subroutine cplfind
1950 
1951 !------------------------------------------------------------
1952 
1953 !> Merge routine needed for mergesort
1954 
1955 subroutine merge(A,X,NA,B,Y,NB,C,Z,NC)
1956 
1957  !--- local kinds ---
1958  integer,parameter :: R8 = ip_double_p
1959  integer,parameter :: IN = ip_i4_p
1960  integer,parameter :: CL = ic_lvar
1961 
1962  integer, intent(in) :: NA,NB,NC ! Normal usage: NA+NB = NC
1963  character(CL), intent(inout) :: A(na) ! B overlays C(NA+1:NC)
1964  integer(IN) , intent(inout) :: X(na) ! B overlays C(NA+1:NC)
1965  character(CL), intent(in) :: B(nb)
1966  integer(IN) , intent(in) :: Y(nb)
1967  character(CL), intent(inout) :: C(nc)
1968  integer(IN) , intent(inout) :: Z(nc)
1969 
1970  integer :: I,J,K
1971  character(*),parameter :: subName = '(Merge) '
1972 
1973 ! write(nulprt,*) subname//' NA,NB,NC = ',NA,NB,NC
1974 
1975  i = 1; j = 1; k = 1;
1976  do while(i <= na .and. j <= nb)
1977  if (a(i) <= b(j)) then
1978  c(k) = a(i)
1979  z(k) = x(i)
1980  i = i+1
1981  else
1982  c(k) = b(j)
1983  z(k) = y(j)
1984  j = j+1
1985  endif
1986  k = k + 1
1987  enddo
1988  do while (i <= na)
1989  c(k) = a(i)
1990  z(k) = x(i)
1991  i = i + 1
1992  k = k + 1
1993  enddo
1994  return
1995 
1996 end subroutine merge
1997 
1998 !------------------------------------------------------------
1999 
2000 !> Generic mergesort routine
2001 
2002 recursive subroutine mergesort(N,A,T,S,Z)
2003 
2004  !--- local kinds ---
2005  integer,parameter :: R8 = ip_double_p
2006  integer,parameter :: IN = ip_i4_p
2007  integer,parameter :: CL = ic_lvar
2008 
2009  integer , intent(in) :: N ! size
2010  character(CL), dimension(N) , intent(inout) :: A ! data to sort
2011  character(CL), dimension((N+1)/2), intent(out) :: T ! data tmp
2012  integer(IN) , dimension(N) , intent(inout) :: S ! sortkey
2013  integer(IN) , dimension((N+1)/2), intent(out) :: Z ! sortkey tmp
2014 
2015  integer :: NA,NB
2016  character(CL) :: V
2017  integer(IN) :: Y
2018  character(*),parameter :: subName = '(MergeSort) '
2019 
2020 ! write(nulprt,*) subname//' N = ',N
2021 
2022  if (n < 2) return
2023  if (n == 2) then
2024  if (a(1) > a(2)) then
2025  v = a(1)
2026  y = s(1)
2027  a(1) = a(2)
2028  s(1) = s(2)
2029  a(2) = v
2030  s(2) = y
2031  endif
2032  return
2033  endif
2034  na=(n+1)/2
2035  nb=n-na
2036 
2037  call mergesort(na,a,t,s,z)
2038  call mergesort(nb,a(na+1),t,s(na+1),z)
2039 
2040  if (a(na) > a(na+1)) then
2041  t(1:na)=a(1:na)
2042  z(1:na)=s(1:na)
2043  call merge(t,z,na,a(na+1),s(na+1),nb,a,s,n)
2044  endif
2045  return
2046 
2047 end subroutine mergesort
2048 
2049 !===============================================================================
2050 
2051 END MODULE mod_oasis_coupler
2052 
2053 
subroutine, public oasis_debug_exit(string)
Used when a subroutine is exited, write info to log file at some debug level.
OASIS partition data and methods.
System type methods.
Generic overloaded interface into MPI max reduction.
Router information for rearranging data on tasks.
Reads the namcouple file for use in OASIS.
Provides a generic and simpler interface into MPI calls for OASIS.
Generic overloaded interface into MPI broadcast.
subroutine, public oasis_coupler_setup()
Main routine to setup couplers.
recursive subroutine mergesort(N, A, T, S, Z)
Generic mergesort routine.
subroutine, public oasis_map_genmap(mapid, namid)
Routine to generate mapping weights data via a direct SCRIP call.
subroutine, public oasis_timer_start(timer_label, barrier)
Start a timer.
subroutine, public oasis_timer_stop(timer_label)
Stop a timer.
Provides a common location for several OASIS variables.
OASIS map (interpolation) data and methods.
subroutine, public oasis_debug_enter(string)
Used when a subroutine is entered, write info to log file at some debug level.
Defines kinds for OASIS.
subroutine, public oasis_debug_note(string)
Used to write information from a subroutine, write info to log file at some debug level...
subroutine, public oasis_flush(nu)
Flushes output to file.
Initialize the OASIS coupler infrastructure.
Character string manipulation methods.
Coupler data for managing all aspects of coupling in OASIS.
subroutine, public oasis_io_read_avfld(filename, av, gsmap, mpicom, avfld, filefld, fldtype)
Reads single field from a file into an attribute Vector.
subroutine cplsort(num, fld, sortkey)
Sort a character array using a sort key.
subroutine merge(A, X, NA, B, Y, NB, C, Z, NC)
Merge routine needed for mergesort.
Performance timer methods.
subroutine, public oasis_abort(id_compid, cd_routine, cd_message)
OASIS abort method, publically available to users.
subroutine cplsortkey(num, arr, sortkey)
Sort an integer array using a sort key.
subroutine, public oasis_string_listgetname(list, k, name, rc)
Get name of k-th field in list.
subroutine oasis_coupler_print(cplid, pcprint)
Print routine for oasis_couplers.
subroutine, public oasis_map_smatreaddnc_ceg(sMat, SgsMap, DgsMap, newdom, fileName, mytask, mpicom, nwgts, areasrc, areadst, ni_i, nj_i, ni_o, nj_o)
Read in mapping matrix data from a SCRIP netCDF file using smart scatter (ceg)
subroutine, public oasis_map_smatreaddnc_orig(sMat, SgsMap, DgsMap, newdom, fileName, mytask, mpicom, nwgts, areasrc, areadst, ni_i, nj_i, ni_o, nj_o)
Read in mapping matrix data from a SCRIP netCDF weights file.
Provides reusable IO routines for OASIS.
Definition: mod_oasis_io.F90:4
subroutine cplfind(num, fldlist, fld, ifind, nfind)
Search a character field list for a matching values.
integer function, public oasis_string_listgetnum(str)
return number of fields in string list
OASIS variable data and methods.
Defines parameters for OASIS.
subroutine, public oasis_part_create(id_part, TYPE, gsize, nx, ny, gridname, gscomm, mpicom)
Create a new partition internally, needed for mapping.