32 integer(kind=ip_intwp_p),
parameter :: debug=2
34 integer(kind=ip_intwp_p),
parameter :: debug=1
36 logical,
save :: lg_mpiflag
50 INTEGER (kind=ip_intwp_p),
intent(out) :: mynummod
51 CHARACTER(len=*) ,
intent(in) :: cdnam
52 INTEGER (kind=ip_intwp_p),
intent(inout),
optional :: kinfo
53 logical ,
intent(in) ,
optional :: coupled
55 integer(kind=ip_intwp_p) :: ierr
56 INTEGER(kind=ip_intwp_p) :: n,nns,iu
57 integer(kind=ip_intwp_p) :: icolor,ikey
58 CHARACTER(len=ic_med) :: filename,filename2
59 character(len=ic_med) :: pio_type
60 integer(kind=ip_intwp_p) :: pio_stride
61 integer(kind=ip_intwp_p) :: pio_root
62 integer(kind=ip_intwp_p) :: pio_numtasks
63 INTEGER(kind=ip_intwp_p),
ALLOCATABLE :: tmparr(:)
64 INTEGER(kind=ip_intwp_p) :: k,i,m,k1,k2
65 INTEGER(kind=ip_intwp_p) :: nt
66 INTEGER(kind=ip_intwp_p) :: nvar
67 INTEGER(kind=ip_intwp_p) :: mpi_size_world
68 INTEGER(kind=ip_intwp_p) :: mpi_rank_world
69 INTEGER(kind=ip_intwp_p) :: mall
71 character(len=ic_lvar),
pointer :: compnmlist(:)
72 logical,
pointer :: coupledlist(:)
73 character(len=ic_lvar) :: tmp_modnam
75 character(len=ic_lvar) :: i_name
76 character(len=*),
parameter :: subname =
'(oasis_init_comp)'
79 if (
present(kinfo))
then
84 oasis_coupled = .true.
85 if (
present(coupled))
then
86 oasis_coupled = coupled
94 CALL mpi_initialized( lg_mpiflag, ierr )
95 IF ( .NOT. lg_mpiflag )
THEN
96 if (oasis_debug >= 0)
WRITE (0,fmt=
'(A)') subname//
': Calling MPI_Init'
99 if (oasis_debug >= 0)
WRITE (0,fmt=
'(A)') subname//
': Not Calling MPI_Init'
104 mpi_comm_global = mpi_comm_world
105 #elif defined use_comm_MPI2
109 CALL mpi_comm_size(mpi_comm_world,mpi_size_world,ierr)
110 CALL mpi_comm_rank(mpi_comm_world,mpi_rank_world,ierr)
111 mpi_rank_global = mpi_rank_world
120 IF (mpi_rank_world == 0)
THEN
123 WRITE(filename,
'(a,i6.6)')
'nout.',mpi_rank_world
124 OPEN(nulprt1,file=filename)
134 IF (mpi_rank_world == 0)
THEN
138 IF (mpi_rank_world /= 0)
THEN
141 oasis_debug = namlogprt
142 timer_debug = namtlogprt
145 lucia_debug = abs(min(namtlogprt,0))
153 IF ( nnamcpl == 0 )
THEN
154 IF (mpi_rank_world == 0)
THEN
155 WRITE (unit = nulprt1,fmt = *) subname,wstr, &
156 'The models are not exchanging any field ($NFIELDS = 0) '
157 WRITE (unit = nulprt1,fmt = *) &
158 'so we force OASIS_debug = 0 for all processors '
174 maxvar = size_namfld * 2
175 IF (mpi_rank_world == 0)
THEN
176 WRITE (unit = nulprt1,fmt = *)
'Total number of coupling fields :',maxvar
180 ALLOCATE(prism_var(maxvar))
188 ALLOCATE(total_namsrcfld(size_namfld))
189 ALLOCATE(total_namdstfld(size_namfld))
199 WRITE(nulprt,*) subname,estr,
'namcouple field numbers do not agree '
200 WRITE(nulprt,*) subname,estr,
'namsrcfld = ',trim(namsrcfld(n))
201 WRITE(nulprt,*) subname,estr,
'namdstfld = ',trim(namdstfld(n))
207 total_namsrcfld(m)=trim(i_name)
209 total_namdstfld(m)=trim(i_name)
214 IF (oasis_debug >= 15 .and. mpi_rank_world == 0)
THEN
216 WRITE (unit = nulprt1,fmt = *) subname,
'Coupling fields namsrcfld:',&
217 trim(total_namsrcfld(m))
218 WRITE (unit = nulprt1,fmt = *) subname,
'Coupling fields namdstfld:',&
219 trim(total_namdstfld(m))
228 if (len_trim(cdnam) > ic_lvar)
then
229 WRITE(nulprt1,*) subname,estr,
'model name too long = ',trim(cdnam)
230 write(nulprt1,*) subname,estr,
'max model name length = ',ic_lvar
241 allocate(compnmlist(mpi_size_world))
242 allocate(coupledlist(mpi_size_world))
243 call mpi_gather(compnm, ic_lvar, mpi_character, compnmlist, ic_lvar, mpi_character, 0, mpi_comm_world, ierr)
244 call mpi_gather(oasis_coupled, 1, mpi_logical, coupledlist, 1, mpi_logical, 0, mpi_comm_world, ierr)
247 prism_modnam(:) =
' '
248 prism_modcpl(:) = .false.
249 if (mpi_rank_world == 0)
then
250 if (oasis_debug >= 15)
then
251 do n = 1,mpi_size_world
252 write(nulprt1,*) subname,
' compnm gather ',n,trim(compnmlist(n)),coupledlist(n)
259 do n = 1,mpi_size_world
262 do while (.not.found .and. m < prism_nmodels)
264 if (compnmlist(n) == prism_modnam(m))
then
266 if (coupledlist(n) .neqv. prism_modcpl(m))
then
267 WRITE(nulprt1,*) subname,estr,
'inconsistent coupled flag in oasis_init_comp.'
268 WRITE(nulprt1,*) subname,estr,
'the optional argument, coupled, in oasis_init_comp '
269 WRITE(nulprt1,*) subname,estr,
'must be identical on all tasks of a component.'
275 prism_nmodels = prism_nmodels + 1
276 if (prism_nmodels > prism_mmodels)
then
277 WRITE(nulprt1,*) subname,estr,
'prism_nmodels too large, increase prism_mmodels in mod_oasis_data'
280 prism_modnam(prism_nmodels) = trim(compnmlist(n))
281 prism_modcpl(prism_nmodels) = coupledlist(n)
287 prism_amodels = prism_nmodels
288 do n = prism_nmodels,1,-1
289 if (.not.prism_modcpl(n))
then
290 tmp_modnam = prism_modnam(n)
291 tmp_modcpl = prism_modcpl(n)
292 do m = n,prism_nmodels-1
293 prism_modnam(m) = prism_modnam(m+1)
294 prism_modcpl(m) = prism_modcpl(m+1)
296 prism_modnam(prism_nmodels) = tmp_modnam
297 prism_modcpl(prism_nmodels) = tmp_modcpl
298 prism_amodels = prism_amodels - 1
303 do n = 1,prism_amodels
304 write(nulprt1,*) subname,
' COUPLED models ',n,trim(prism_modnam(n)),prism_modcpl(n)
305 if (.not.prism_modcpl(n))
then
306 WRITE(nulprt1,*) subname,estr,
'model expected to be coupled but is not = ',trim(prism_modnam(n))
311 do n = prism_amodels+1,prism_nmodels
312 write(nulprt1,*) subname,
' UNCOUPLED models ',n,trim(prism_modnam(n)),prism_modcpl(n)
313 if (prism_modcpl(n))
then
314 WRITE(nulprt1,*) subname,estr,
'model expected to be uncoupled but is not = ',trim(prism_modnam(n))
321 deallocate(compnmlist)
322 deallocate(coupledlist)
327 call
oasis_mpi_bcast(prism_nmodels,mpi_comm_world,subname//
' prism_nmodels')
328 call
oasis_mpi_bcast(prism_amodels,mpi_comm_world,subname//
' prism_amodels')
329 call
oasis_mpi_bcast(prism_modnam ,mpi_comm_world,subname//
' prism_modnam')
330 call
oasis_mpi_bcast(prism_modcpl ,mpi_comm_world,subname//
' prism_modcpl')
337 do n = 1,prism_nmodels
338 if (trim(cdnam) == trim(prism_modnam(n))) compid = n
341 IF (mpi_rank_world == 0)
THEN
342 WRITE(nulprt1,*) subname,
'cdnam :',trim(cdnam),
' mynummod :',mynummod
348 WRITE(nulprt1,*) subname,estr,
'prism_modnam internal inconsistency = ',trim(cdnam)
366 call mpi_comm_split(mpi_comm_world,icolor,ikey,mpi_comm_local,ierr)
374 if (.not.oasis_coupled) icolor = 0
375 call mpi_comm_split(mpi_comm_world,icolor,ikey,mpi_comm_global,ierr)
378 #elif defined use_comm_MPI2
381 mpi_comm_local = mpi_comm_world
390 IF ( lucia_debug > 0 .AND. oasis_debug > 0 )
THEN
391 WRITE (unit = nulprt1,fmt = *) subname,wstr, &
392 ' With LUCIA load balance analysis '
393 WRITE (unit = nulprt1,fmt = *) &
394 ' we set OASIS_debug = 0 '
399 IF (mpi_rank_world == 0)
CLOSE(nulprt1)
401 if (.not.oasis_coupled)
then
405 CALL mpi_comm_size(mpi_comm_global,mpi_size_global,ierr)
406 CALL mpi_comm_rank(mpi_comm_global,mpi_rank_global,ierr)
408 CALL mpi_comm_size(mpi_comm_local,mpi_size_local,ierr)
409 CALL mpi_comm_rank(mpi_comm_local,mpi_rank_local,ierr)
419 IF (oasis_debug <= 1)
THEN
420 CALL
oasis_mpi_bcast(iu,mpi_comm_local,trim(subname)//
':unit of master',0)
421 IF (mpi_rank_local == 0)
THEN
423 WRITE(filename,
'(a,i2.2)')
'debug.root.',compid
424 OPEN(nulprt,file=filename)
425 WRITE(nulprt,*) subname,
' OPEN debug file for root pe, unit :',nulprt
428 nulprt=iu+mpi_size_global
429 WRITE(filename2,
'(a,i2.2)')
'debug.notroot.',compid
430 OPEN(nulprt,file=filename2,position=
'append')
436 WRITE(filename,
'(a,i2.2,a,i6.6)')
'debug.',compid,
'.',mpi_rank_local
437 OPEN(nulprt,file=filename)
438 WRITE(nulprt,*) subname,
' OPEN debug file, unit :',nulprt
442 IF ( (oasis_debug == 1) .AND. (mpi_rank_local == 0)) oasis_debug=10
444 IF (oasis_debug >= 2)
THEN
445 WRITE(nulprt,*) subname,
' model compid ',trim(cdnam),compid
453 IF ( lucia_debug > 0 )
THEN
454 IF (mpi_size_local < 20 )
THEN
457 ELSE IF (mpi_size_local < 100 .AND. mod(mpi_rank_local,mpi_size_local/5) == 0 )
THEN
459 ELSE IF (mpi_size_local >= 100 .AND. mod(mpi_rank_local,mpi_size_local/20) == 0 )
THEN
465 IF (nullucia /= 0)
THEN
466 WRITE(filename,
'(a,i2.2,a,i6.6)')
'lucia.',compid,
'.',mpi_rank_local
467 OPEN(nullucia,file=filename)
491 call oasis_ioshr_init(mpi_comm_local,pio_type,pio_stride,pio_root,pio_numtasks)
515 if (oasis_debug >= 15)
then
516 write(nulprt,*) subname,
' compid = ',compid
517 write(nulprt,*) subname,
' compnm = ',trim(compnm)
518 write(nulprt,*) subname,
' mpi_comm_world = ',mpi_comm_world
519 write(nulprt,*) subname,
' mpi_comm_global= ',mpi_comm_global
520 write(nulprt,*) subname,
' size_global= ',mpi_size_global
521 write(nulprt,*) subname,
' rank_global= ',mpi_rank_global
522 write(nulprt,*) subname,
' mpi_comm_local = ',mpi_comm_local
523 write(nulprt,*) subname,
' size_local = ',mpi_size_local
524 write(nulprt,*) subname,
' rank_local = ',mpi_rank_local
525 write(nulprt,*) subname,
' root_local = ',mpi_root_local
526 write(nulprt,*) subname,
' OASIS_debug = ',oasis_debug
527 do n = 1,prism_amodels
528 write(nulprt,*) subname,
' n,prism_model,root = ',&
529 n,trim(prism_modnam(n)),mpi_root_global(n)
534 IF ( lucia_debug > 0 )
THEN
537 IF ( nullucia /= 0 )
THEN
538 WRITE(nullucia, fmt=
'(A,F16.5)')
'Balance: IT ', mpi_wtime()
539 WRITE(nullucia, fmt=
'(A12,A)' )
'Balance: MD ', trim(compnm)
559 INTEGER (kind=ip_intwp_p),
intent(inout),
optional :: kinfo
561 integer(kind=ip_intwp_p) :: ierr
562 character(len=*),
parameter :: subname =
'(oasis_terminate)'
566 if (.not. oasis_coupled)
then
571 if (
present(kinfo))
then
586 IF ( .NOT. lg_mpiflag )
THEN
587 IF (oasis_debug >= 2)
THEN
588 WRITE (nulprt,fmt=
'(A)') subname//
': Calling MPI_Finalize'
591 CALL mpi_finalize( ierr )
593 IF (oasis_debug >= 2)
THEN
594 WRITE (nulprt,fmt=
'(A)') subname//
': Not Calling MPI_Finalize'
605 IF (mpi_rank_local == 0)
THEN
606 WRITE(nulprt,*) subname,
' SUCCESSFUL RUN'
622 INTEGER (kind=ip_intwp_p),
intent(inout),
optional :: kinfo
624 integer (kind=ip_intwp_p) :: n
625 integer (kind=ip_intwp_p) :: lkinfo
626 integer (kind=ip_intwp_p) :: icpl, ierr
627 integer (kind=ip_intwp_p) :: newcomm
628 character(len=*),
parameter :: subname =
'(oasis_enddef)'
637 if (enddef_called)
then
638 write(nulprt,*) subname,estr,
'enddef called already'
641 enddef_called = .true.
643 if (.not. oasis_coupled)
then
658 if (mpi_comm_local /= mpi_comm_null) icpl = 1
659 CALL mpi_comm_split(mpi_comm_global,icpl,1,newcomm,ierr)
660 mpi_comm_global = newcomm
666 if (mpi_comm_global /= mpi_comm_null)
then
672 CALL mpi_comm_size(mpi_comm_global,mpi_size_global,ierr)
673 CALL mpi_comm_rank(mpi_comm_global,mpi_rank_global,ierr)
685 if (oasis_debug >= 2)
then
686 write(nulprt,*) subname,
' compid = ',compid
687 write(nulprt,*) subname,
' compnm = ',trim(compnm)
688 write(nulprt,*) subname,
' mpi_comm_world = ',mpi_comm_world
689 write(nulprt,*) subname,
' mpi_comm_global= ',mpi_comm_global
690 write(nulprt,*) subname,
' size_global= ',mpi_size_global
691 write(nulprt,*) subname,
' rank_global= ',mpi_rank_global
692 write(nulprt,*) subname,
' mpi_comm_local = ',mpi_comm_local
693 write(nulprt,*) subname,
' size_local = ',mpi_size_local
694 write(nulprt,*) subname,
' rank_local = ',mpi_rank_local
695 write(nulprt,*) subname,
' root_local = ',mpi_root_local
696 write(nulprt,*) subname,
' OASIS_debug = ',oasis_debug
697 do n = 1,prism_amodels
698 write(nulprt,*) subname,
' n,prism_model,root = ',&
699 n,trim(prism_modnam(n)),mpi_root_global(n)
724 do n = 1,prism_amodels
725 if (compid == n)
then
736 call mct_world_init(prism_amodels,mpi_comm_global,mpi_comm_local,compid)
737 IF (oasis_debug >= 2)
THEN
738 WRITE(nulprt,*) subname,
' done mct_world_init '
747 IF (oasis_debug >= 2)
THEN
748 WRITE(nulprt,*) subname,
' done prism_coupler_setup '
758 IF (oasis_debug >= 2)
THEN
759 WRITE(nulprt,*) subname,
' done prism_advance_init '
768 if (
present(kinfo))
then
785 INTEGER(kind=ip_intwp_p) :: n, ierr
786 INTEGER(kind=ip_intwp_p),
ALLOCATABLE :: tmparr(:)
787 character(len=*),
parameter :: subname =
'(oasis_setrootglobal)'
793 if (
allocated(mpi_root_global))
then
794 deallocate(mpi_root_global)
796 allocate(mpi_root_global(prism_amodels))
797 allocate(tmparr(prism_amodels))
799 do n = 1,prism_amodels
800 if (compid == n .and. mpi_rank_local == mpi_root_local)
then
801 tmparr(n) = mpi_rank_global
805 string=subname//
':mpi_root_global',all=.true.)
808 do n = 1,prism_amodels
809 IF (mpi_root_global(n) < 0)
THEN
810 WRITE(nulprt,*) subname,estr,
'global root invalid, check couplcomm for active tasks'
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.
Reads the namcouple file for use in OASIS.
subroutine mod_oasis_setrootglobal()
Local method to compute each models' global task ids, exists for reuse in enddef. ...
Provides methods for querying memory use.
Provides a generic and simpler interface into MPI calls for OASIS.
Generic overloaded interface into MPI broadcast.
Advances the OASIS coupling.
subroutine, public oasis_unitsetmin(uio)
Set the minimum unit number allowed.
subroutine, public oasis_coupler_setup()
Main routine to setup couplers.
subroutine, public oasis_mem_print(iunit, string)
Print memory use.
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.
subroutine, public oasis_debug_enter(string)
Used when a subroutine is entered, 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.
subroutine, public oasis_enddef(kinfo)
OASIS user interface specifying the OASIS definition phase is complete.
subroutine oasis_data_zero()
subroutine, public oasis_part_setup()
Synchronize partitions across all tasks, called at oasis enddef.
subroutine, public oasis_var_setup()
Synchronize variables across all tasks, called at oasis enddef.
subroutine, public oasis_write2files()
Interface that actually writes fields to grid files.
Performance timer methods.
IO interfaces based on pio (not supported yet)
subroutine, public oasis_unitget(uio)
Get a free unit number.
subroutine, public oasis_abort(id_compid, cd_routine, cd_message)
OASIS abort method, publically available to users.
subroutine, public oasis_namcouple_init()
Reads the namcouple.
subroutine, public oasis_string_listgetname(list, k, name, rc)
Get name of k-th field in list.
High level OASIS user interfaces.
subroutine, public oasis_mpi_barrier(comm, string)
Call MPI_BARRIER for a particular communicator.
OASIS grid data and methods.
subroutine, public oasis_init_comp(mynummod, cdnam, kinfo, coupled)
OASIS user init method.
subroutine, public oasis_timer_init(app, file, nt)
Initializes the timer methods, called once in an application.
subroutine, public oasis_advance_init(kinfo)
Initializes the OASIS fields.
integer function, public oasis_string_listgetnum(str)
return number of fields in string list
subroutine, public oasis_mem_init(iunit)
Initialize memory conversion to MB.
OASIS variable data and methods.
Defines parameters for OASIS.
subroutine, public oasis_timer_print(timer_label)
Print timers.
subroutine, public oasis_terminate(kinfo)
OASIS user finalize method.