39 type(mct_router) :: router
42 integer(kind=ip_i4_p),
public,
parameter :: prism_coupler_avsmax=5
47 type(mct_avect) :: avect1
48 type(mct_avect) :: avect1m
49 type(mct_avect) :: avect2
50 type(mct_avect) :: avect3
51 type(mct_avect) :: avect4
52 type(mct_avect) :: avect5
53 logical :: avon(prism_coupler_avsmax)
54 character(len=ic_xl) :: rstfile
55 character(len=ic_xl) :: inpfile
56 character(len=ic_xl) :: fldlist
57 integer(kind=ip_i4_p) :: nflds
58 integer(kind=ip_i4_p),
pointer :: varid(:)
60 integer(kind=ip_i4_p) :: namid
61 integer(kind=ip_i4_p) :: partid
62 integer(kind=ip_i4_p) :: rpartid
63 integer(kind=ip_i4_p) :: routerid
64 integer(kind=ip_i4_p) :: mapperid
65 character(len=ic_med) :: maploc
66 integer(kind=ip_i4_p) :: ops
67 integer(kind=ip_i4_p) :: comp
68 integer(kind=ip_i4_p) :: tag
69 integer(kind=ip_i4_p) :: seq
70 integer(kind=ip_i4_p) :: dt
71 integer(kind=ip_i4_p) :: lag
72 integer(kind=ip_i4_p) :: maxtime
73 integer(kind=ip_i4_p) :: trans
74 integer(kind=ip_i4_p) :: conserv
75 character(len=ic_med) :: consopt
76 integer(kind=ip_i4_p) :: getput
82 real(kind=ip_double_p):: sndmult
83 real(kind=ip_double_p):: sndadd
84 real(kind=ip_double_p):: rcvmult
85 real(kind=ip_double_p):: rcvadd
87 integer(kind=ip_i4_p) :: ltime
88 integer(kind=ip_i4_p),
pointer :: avcnt(:)
89 integer(kind=ip_i4_p),
pointer :: status(:)
92 integer(kind=ip_i4_p) :: prism_mrouter
93 integer(kind=ip_i4_p) :: prism_nrouter = 0
96 integer(kind=ip_i4_p) ,
public :: prism_mcoupler
100 integer(kind=ip_i4_p) ,
public :: lcouplerid
101 integer(kind=ip_i4_p) ,
public :: lcouplertime
102 integer(kind=ip_i4_p) ,
public :: lastseq
103 integer(kind=ip_i4_p) ,
public :: lastseqtime
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
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
145 character(len=ic_lvar):: otfld
146 character(len=ic_xl) :: otfldlist
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
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(:)
164 integer(kind=ip_i4_p) ,
pointer :: namsrc_checkused_g(:)
166 integer(kind=ip_i4_p) :: num
167 integer(kind=ip_i4_p) ,
pointer :: namnum(:)
168 integer(kind=ip_i4_p) ,
pointer :: fldnum(:)
169 character(len=ic_lvar),
pointer :: fld(:)
170 end type sortnamfld_type
171 type(sortnamfld_type) :: sortnsrc
172 type(sortnamfld_type) :: sortndst
174 integer(kind=ip_i4_p) :: num
175 integer(kind=ip_i4_p) ,
pointer :: modnum(:)
176 integer(kind=ip_i4_p) ,
pointer :: varnum(:)
177 character(len=ic_lvar),
pointer :: fld(:)
178 end type sortvarfld_type
179 type(sortvarfld_type) :: sortvars
180 type(sortvarfld_type) :: sorttest
181 integer(kind=ip_i4_p) ,
pointer :: sortkey(:)
183 character(len=*),
parameter :: smatread_method =
'ceg'
184 logical,
parameter :: local_timers_on = .false.
186 character(len=*),
parameter :: subname =
'(oasis_coupler_setup)'
196 write(nulprt,*) subname,
' smatread_method = ',trim(smatread_method)
205 prism_mrouter = nnamcpl * 2
206 allocate(prism_router(prism_mrouter))
209 prism_mmapper = nnamcpl
210 allocate(prism_mapper(prism_mmapper))
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.
222 prism_mcoupler = nnamcpl
223 allocate(prism_coupler_put(prism_mcoupler))
224 allocate(prism_coupler_get(prism_mcoupler))
226 do nc = 1,prism_mcoupler
229 pcpointer => prism_coupler_put(nc)
230 pcpntpair => prism_coupler_get(nc)
233 pcpointer => prism_coupler_get(nc)
234 pcpntpair => prism_coupler_put(nc)
236 pcpointer%rstfile =
""
237 pcpointer%inpfile =
""
238 pcpointer%fldlist =
""
241 pcpointer%valid = .false.
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
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
272 lcouplertime = ispval
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))
294 do n = 1,prism_amodels
295 if (n == compid)
then
299 do n1 = 1, prism_nvar
300 myvar(n1) = trim(prism_var(n1)%name)
301 myops(n1) = prism_var(n1)%ops
304 if (myvar(n1) == myvar(n2))
then
305 WRITE(nulprt,*) subname,estr,
'variable name defined more than once by def_var = ',trim(myvar(n1))
311 if (oasis_debug >= 5)
then
312 write(nulprt,*) subname,
' BCAST from ',n,mpi_root_global(n)
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
322 if (oasis_debug >= 5)
then
323 write(nulprt,*) subname,
' bcast myvar ',trim(myvar(1))
326 allvar(:,n) = myvar(:)
328 if (oasis_debug >= 5)
then
329 write(nulprt,*) subname,
' bcast myops ',myops(1)
332 allops(:,n) = myops(:)
336 deallocate(myvar,myops)
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)
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),&
358 do n = 1,prism_amodels
361 allocate(sortvars%fld(n1))
362 allocate(sortvars%modnum(n1))
363 allocate(sortvars%varnum(n1))
364 allocate(sortkey(n1))
368 do n = 1,prism_amodels
372 sortvars%fld(n1) = allvar(n2,n)
373 sortvars%modnum(n1) = n
374 sortvars%varnum(n1) = n2
378 call
cplsort(sortvars%num, sortvars%fld, sortkey)
379 call
cplsortkey(sortvars%num, sortvars%modnum, sortkey)
380 call
cplsortkey(sortvars%num, sortvars%varnum, sortkey)
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))
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))
427 allocate(sortnsrc%fld(n1))
428 allocate(sortnsrc%namnum(n1))
429 allocate(sortnsrc%fldnum(n1))
431 allocate(sortndst%fld(n2))
432 allocate(sortndst%namnum(n2))
433 allocate(sortndst%fldnum(n2))
436 allocate(namsrc_checkused(sortnsrc%num))
441 allocate(sortkey(sortnsrc%num))
447 sortnsrc%namnum(n1) = nn
448 sortnsrc%fldnum(n1) = n2
453 call
cplsort(sortnsrc%num, sortnsrc%fld, sortkey)
454 call
cplsortkey(sortnsrc%num, sortnsrc%namnum, sortkey)
455 call
cplsortkey(sortnsrc%num, sortnsrc%fldnum, sortkey)
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))
468 allocate(sortkey(sortndst%num))
474 sortndst%namnum(n1) = nn
475 sortndst%fldnum(n1) = n2
480 call
cplsort(sortndst%num, sortndst%fld, sortkey)
481 call
cplsortkey(sortndst%num, sortndst%namnum, sortkey)
482 call
cplsortkey(sortndst%num, sortndst%fldnum, sortkey)
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))
493 if (oasis_debug >= 1500)
then
495 write(nulprt,*) subname,
' Test sort code: '
498 allocate(sorttest%fld(n1))
499 allocate(sorttest%modnum(n1))
500 allocate(sorttest%varnum(n1))
501 allocate(sortkey(n1))
504 sorttest%fld(:) =
'A'
505 do n1 = 1,sorttest%num
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
518 call
cplsort(sorttest%num, sorttest%fld, sortkey)
519 call
cplsortkey(sorttest%num, sorttest%modnum, sortkey)
520 call
cplsortkey(sorttest%num, sorttest%varnum, sortkey)
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))
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))
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))
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))
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))
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))
564 deallocate(sorttest%fld)
565 deallocate(sorttest%modnum)
566 deallocate(sorttest%varnum)
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))
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))
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))
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))
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))
623 do nv1 = 1,prism_nvar
629 part1 = prism_var(nv1)%part
630 myfld = prism_var(nv1)%name
632 IF (oasis_debug >= 20)
THEN
634 WRITE(nulprt,*) subname,
' get part and fld ',nv1,part1,trim(myfld)
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)
653 do nf = ifind,ifind+nfind-1
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)
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)
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
686 if (flag /= oasis_notdef)
then
694 IF (oasis_debug >= 20)
THEN
695 WRITE(nulprt,*) subname,
' migrate namcouple to part '
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))
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))
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)
723 if (oasis_debug >= 20)
then
724 write(nulprt,
'(1x,2a,4i6,2a)') subname,
' ca: myfld',nn,compid,&
725 nv1,myfldi,
' ',trim(myfld)
734 otfld =
'NOmatchNOyesNOyesNO'
738 IF (oasis_debug >= 20)
THEN
739 WRITE(nulprt,*) subname,
' otfld ',trim(otfld)
748 call
cplfind(sortvars%num, sortvars%fld, otfld, ifind, nfind)
756 do nvf = ifind, ifind+nfind-1
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
769 if (prism_var(nv1)%ops == oasis_in)
then
772 do while (n1 < sortnsrc%num .and. .not.found2)
774 if (nn == sortnsrc%namnum(n1) .and. myfldi == sortnsrc%fldnum(n1))
then
775 namsrc_checkused(n1) = 1
777 if (oasis_debug >= 20)
then
778 write(nulprt,*) subname,
' set dst checkused ',trim(myfld),
':',trim(otfld),n1
786 nm = sortvars%modnum(nvf)
787 nv = sortvars%varnum(nvf)
789 if (oasis_debug >= 20)
then
790 write(nulprt,*) subname,
' match otfld ',trim(otfld),nn
799 if (namfldops(nn) == ip_exported .or. namfldops(nn) == ip_expout)
then
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)
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)
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)
831 if (flag == oasis_in .and. found)
then
832 write(nulprt,*) subname,estr,
'found two sources for field = ',trim(otfld)
838 if (flag == oasis_out) pcpointer => prism_coupler_put(nc)
839 if (flag == oasis_in) pcpointer => prism_coupler_get(nc)
845 IF (oasis_debug >= 20)
THEN
846 WRITE(nulprt,*) subname,
' set prism_coupler '
857 pcpointer%nflds = pcpointer%nflds + 1
879 if (pcpointer%nflds == 1)
then
880 pcpointer%fldlist = trim(myfldlist)
881 deallocate(pcpointer%varid)
883 pcpointer%varid(:) = ispval
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
892 pcpointer%varid(myfldi) = nv1
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'
904 prism_var(nv1)%cpl(prism_var(nv1)%ncpl) = nc
912 if (pcpointer%valid)
then
913 if (pcpointer%comp /= nm)
then
914 WRITE(nulprt,*) subname,estr,
'mismatch in field comp for var = ',trim(myfld)
917 if (pcpointer%namID /= nn)
then
918 WRITE(nulprt,*) subname,estr,
'mismatch in field namID for var = ',trim(myfld)
921 if (pcpointer%partID /= part1)
then
922 WRITE(nulprt,*) subname,estr,
'mismatch in field partID for var = ',trim(myfld)
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
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)
960 IF (oasis_debug >= 20)
THEN
961 WRITE(nulprt,*) subname,
' inout flags '
965 if (namfldops(nn) == ip_output .or. namfldops(nn) == ip_expout)
then
966 pcpointer%output = .true.
967 pcpointer%getput = oasis3_put
969 if (namfldops(nn) == ip_input)
then
970 pcpointer%input = .true.
971 pcpointer%getput = oasis3_get
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
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 '
995 pcpointer%routerID = prism_nrouter
1003 IF (oasis_debug >= 20)
THEN
1004 WRITE(nulprt,*) subname,
' mapper '
1008 tmp_mapfile = nammapfil(nn)
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'
1015 tmp_mapfile =
'rmp_'//trim(namsrcgrd(nn))//
'_to_'//trim(namdstgrd(nn))//&
1016 &
'_'//trim(namscrmet(nn))//
'.nc'
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
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
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 '
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)
1059 pcpointer%mapperID = mapid
1063 pcpointer%valid = .true.
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.)
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))
1091 deallocate(namsrc_checkused_g)
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)
1106 if (oasis_debug >= 20)
then
1108 write(nulprt,*) subname,
' couplers setup'
1109 do nc = 1,prism_mcoupler
1119 if (mpi_comm_local == mpi_comm_null)
then
1135 do nc = 1,prism_mcoupler
1138 pcpointer => prism_coupler_put(nc)
1139 pcpntpair => prism_coupler_get(nc)
1142 pcpointer => prism_coupler_get(nc)
1143 pcpntpair => prism_coupler_put(nc)
1145 if (oasis_debug >= 20)
then
1146 write(nulprt,*) subname,
' DEBUG cb:initialize coupler ',nc,npc,pcpointer%valid
1150 if (pcpointer%valid)
then
1152 if (oasis_debug >= 5)
then
1153 write(nulprt,*) subname,
' DEBUG ci:initialize coupler ',nc,npc
1157 namid = pcpointer%namID
1158 part1 = pcpointer%partID
1159 mapid = pcpointer%mapperID
1161 if (part1 <= 0)
then
1162 write(nulprt,*) subname,estr,
'part1 invalid = ',part1
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)
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 '
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
1210 if (prism_mapper(mapid)%init)
then
1215 if (pcpointer%getput == oasis3_put)
then
1216 part2 = prism_mapper(mapid)%dpart
1218 part2 = prism_mapper(mapid)%spart
1220 gsize = mct_gsmap_gsize(prism_part(part2)%gsmap)
1231 if (oasis_debug >= 15)
then
1232 write(nulprt,*) subname,
' DEBUG ci:read mapfile ',trim(prism_mapper(mapid)%file)
1235 if (mpi_rank_local == 0)
then
1238 inquire(file=trim(prism_mapper(mapid)%file),exist=exists)
1240 if (oasis_debug >= 15)
then
1241 write(nulprt,*) subname,
' DEBUG ci: inquire mapfile ',&
1242 trim(prism_mapper(mapid)%file),exists
1245 if (.not.exists)
then
1246 if (trim(namscrmet(namid)) /= trim(cspval))
then
1255 write(nulprt,*) subname,estr,
'map file does not exist and SCRIPR not set = ',&
1256 trim(prism_mapper(mapid)%file)
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
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)
1287 if (pcpointer%getput == oasis3_put)
then
1288 nx = namdst_nx(namid)
1289 ny = namdst_ny(namid)
1290 gridname = trim(namdstgrd(namid))
1292 nx = namsrc_nx(namid)
1293 ny = namsrc_ny(namid)
1294 gridname = trim(namsrcgrd(namid))
1300 call
oasis_part_create(part2,
'1d',gsize,nx,ny,gridname,prism_part(part1)%mpicom,mpi_comm_local)
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)
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)
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)
1325 if (pcpointer%getput == oasis3_put)
then
1327 prism_mapper(mapid)%dpart = part2
1329 prism_mapper(mapid)%spart = part2
1332 spart = prism_mapper(mapid)%spart
1333 dpart = prism_mapper(mapid)%dpart
1337 if (prism_mapper(mapid)%opt ==
'opt')
then
1338 if (prism_part(spart)%gsize > prism_part(dpart)%gsize)
then
1343 elseif (prism_mapper(mapid)%opt ==
'bfb')
then
1345 elseif (prism_mapper(mapid)%opt ==
'sum')
then
1348 write(nulprt,*) subname,estr,
'mapper opt invalid expect bfb or sum =',trim(prism_mapper(mapid)%opt)
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)
1357 prism_mapper(mapid)%optval = trim(cstring)
1366 if (smatread_method ==
"ceg")
then
1369 trim(cstring),trim(prism_mapper(mapid)%file),mpi_rank_local,mpi_comm_local,nwgts)
1374 trim(cstring),trim(prism_mapper(mapid)%file),mpi_rank_local,mpi_comm_local,nwgts)
1378 prism_mapper(mapid)%nwgts = nwgts
1379 allocate(prism_mapper(mapid)%sMatP(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))
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
1403 if (.not.prism_mapper(mapid)%AVred .and. pcpointer%conserv /= ip_cnone)
then
1406 spart = prism_mapper(mapid)%spart
1407 dpart = prism_mapper(mapid)%dpart
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
1414 prism_part(spart)%gsmap,mpi_comm_local,
'mask',trim(gridname)//
'.msk',fldtype=
'int')
1416 prism_part(spart)%gsmap,mpi_comm_local,
'area',trim(gridname)//
'.srf',fldtype=
'real')
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
1423 prism_part(dpart)%gsmap,mpi_comm_local,
'mask',trim(gridname)//
'.msk',fldtype=
'int')
1425 prism_part(dpart)%gsmap,mpi_comm_local,
'area',trim(gridname)//
'.srf',fldtype=
'real')
1427 prism_mapper(mapid)%AVred = .true.
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(:,:))
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)
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 '
1472 pcpointer%rpartID = part2
1497 do nc = 1, prism_mcoupler
1501 pcpointer => prism_coupler_put(nc)
1502 pcpntpair => prism_coupler_get(nc)
1505 pcpointer => prism_coupler_get(nc)
1506 pcpntpair => prism_coupler_put(nc)
1509 namid = pcpointer%namID
1510 part1 = pcpointer%partID
1511 mapid = pcpointer%mapperID
1522 if (pcpointer%sndrcv)
then
1524 if (oasis_debug >= 15)
then
1525 write(nulprt,*) subname,
' DEBUG ci:initialize router ',pcpointer%routerID,&
1526 pcpointer%comp,pcpointer%rpartID
1530 if (compid == pcpointer%comp)
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
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)
1545 if (oasis_debug >= 15)
then
1546 write(nulprt,*) subname,
" DEBUG ci:done initializing prism_router",&
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)
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)
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)
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)
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)
1573 if (oasis_debug >= 15)
then
1574 write(nulprt,*) subname,
" DEBUG ci:done initializing prism_router",&
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)
1590 call mct_router_init(pcpointer%comp,prism_part(pcpointer%rpartID)%gsmap, &
1591 mpi_comm_local,prism_router(pcpointer%routerID)%router)
1593 if (oasis_debug >= 15)
then
1594 write(nulprt,*) subname,
" DEBUG ci:done initializing prism_router",&
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)
1619 if (oasis_debug >= 2)
then
1621 write(nulprt,*) subname,
' couplers initialized'
1622 do nc = 1,prism_mcoupler
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)
1655 integer(ip_i4_p),
intent(in) :: cplid
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)'
1664 mapid = pcprint%mapperid
1665 rouid = pcprint%routerid
1666 parid = pcprint%partid
1667 rpard = pcprint%rpartid
1668 namid = pcprint%namid
1669 nflds = pcprint%nflds
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
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
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)
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
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
1730 write(nulprt,*) subname,
' to nx,ny ',prism_part(dpart)%gsize, prism_part(dpart)%nx,&
1731 prism_part(dpart)%ny
1756 integer,
parameter :: R8 = ip_double_p
1757 integer,
parameter :: IN = ip_i4_p
1758 integer,
parameter :: CL = ic_lvar
1762 integer(IN),
intent(in) :: num
1763 character(len=CL),
intent(inout) :: fld(:)
1764 integer(IN) ,
intent(inout) :: sortkey(:)
1769 integer(IN) :: n1,n2
1771 character(CL),
pointer :: tmpfld(:)
1772 integer(IN) ,
pointer :: tmpkey(:)
1775 character(*),
parameter :: subName =
'(cplsort) '
1783 allocate(tmpfld((num+1)/2))
1784 allocate(tmpkey((num+1)/2))
1785 call
mergesort(num,fld,tmpfld,sortkey,tmpkey)
1808 integer,
parameter :: R8 = ip_double_p
1809 integer,
parameter :: IN = ip_i4_p
1810 integer,
parameter :: CL = ic_lvar
1814 integer(IN),
intent(in) :: num
1815 integer(IN),
intent(inout) :: arr(:)
1816 integer(IN),
intent(in) :: sortkey(:)
1821 integer(IN) :: n1,n2
1822 integer(IN),
pointer :: tmparr(:)
1825 character(*),
parameter :: subName =
'(cplsortkey) '
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)
1838 allocate(tmparr(num))
1839 tmparr(1:num) = arr(1:num)
1841 arr(n1) = tmparr(sortkey(n1))
1860 subroutine cplfind(num, fldlist, fld, ifind, nfind)
1865 integer,
parameter :: R8 = ip_double_p
1866 integer,
parameter :: IN = ip_i4_p
1867 integer,
parameter :: CL = ic_lvar
1871 integer(IN),
intent(in) :: num
1872 character(len=CL),
intent(in) :: fldlist(:)
1873 character(len=CL),
intent(in) :: fld
1874 integer(IN) ,
intent(out) :: ifind
1875 integer(IN) ,
intent(out) :: nfind
1880 integer(IN) :: is,ie,im
1884 character(*),
parameter :: subName =
'(cplfind) '
1903 if (.not.found)
then
1905 if (fld == fldlist(im)) found = .true.
1907 if (.not.found)
then
1909 if (fld == fldlist(im)) found = .true.
1914 do while (.not.found .and. ie > is)
1919 if (fld == fldlist(im))
then
1921 elseif (fld > fldlist(im))
then
1934 do while (fld == fldlist(is-1) .and. is > 1)
1939 do while (fld == fldlist(ie+1) .and. ie < num)
1944 nfind = (ie - is + 1)
1958 integer,
parameter :: R8 = ip_double_p
1959 integer,
parameter :: IN = ip_i4_p
1960 integer,
parameter :: CL = ic_lvar
1962 integer,
intent(in) :: NA,NB,NC
1963 character(CL),
intent(inout) :: A(na)
1964 integer(IN) ,
intent(inout) :: X(na)
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)
1971 character(*),
parameter :: subName =
'(Merge) '
1975 i = 1; j = 1; k = 1;
1976 do while(i <= na .and. j <= nb)
1977 if (a(i) <= b(j))
then
1996 end subroutine merge
2005 integer,
parameter :: R8 = ip_double_p
2006 integer,
parameter :: IN = ip_i4_p
2007 integer,
parameter :: CL = ic_lvar
2009 integer ,
intent(in) :: N
2010 character(CL),
dimension(N) ,
intent(inout) :: A
2011 character(CL),
dimension((N+1)/2),
intent(out) :: T
2012 integer(IN) ,
dimension(N) ,
intent(inout) :: S
2013 integer(IN) ,
dimension((N+1)/2),
intent(out) :: Z
2018 character(*),
parameter :: subName =
'(MergeSort) '
2024 if (a(1) > a(2))
then
2040 if (a(na) > a(na+1))
then
2043 call
merge(t,z,na,a(na+1),s(na+1),nb,a,s,n)
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.
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.
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.
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.