source: CPL/oasis3-mct/branches/OASIS3-MCT_2.0_branch/lib/psmile/src/mod_oasis_method.F90 @ 4775

Last change on this file since 4775 was 4775, checked in by aclsce, 4 years ago
  • Imported oasis3-mct from Cerfacs svn server (not suppotred anymore).

The version has been extracted from ​https://oasis3mct.cerfacs.fr/svn/branches/OASIS3-MCT_2.0_branch/oasis3-mct@1818
File size: 21.3 KB
Line 
1MODULE mod_oasis_method
2
3   USE mod_oasis_kinds
4   USE mod_oasis_sys
5   USE mod_oasis_data
6   USE mod_oasis_parameters
7   USE mod_oasis_namcouple
8   USE mod_oasis_coupler
9   USE mod_oasis_advance
10   USE mod_oasis_timer
11   USE mod_oasis_ioshr
12   USE mod_oasis_grid
13   USE mod_oasis_mpi
14   USE mod_oasis_string
15   USE mct_mod
16
17   IMPLICIT NONE
18
19   private
20
21   public oasis_init_comp
22   public oasis_terminate
23   public oasis_get_localcomm
24   public oasis_set_couplcomm
25   public oasis_create_couplcomm
26   public oasis_get_debug
27   public oasis_set_debug
28   public oasis_get_intercomm
29   public oasis_get_intracomm
30   public oasis_enddef
31
32#ifdef __VERBOSE
33   integer(kind=ip_intwp_p),parameter :: debug=2
34#else
35   integer(kind=ip_intwp_p),parameter :: debug=1
36#endif
37   logical,save :: lg_mpiflag
38
39CONTAINS
40
41!----------------------------------------------------------------------
42   SUBROUTINE oasis_init_comp(mynummod,cdnam,kinfo)
43
44   ! This is COLLECTIVE, all pes must call
45
46   IMPLICIT NONE
47
48   INTEGER (kind=ip_intwp_p),intent(out)   :: mynummod     
49   CHARACTER(len=*)         ,intent(in)    :: cdnam
50   INTEGER (kind=ip_intwp_p),intent(inout),optional :: kinfo
51!  ---------------------------------------------------------
52   integer(kind=ip_intwp_p) :: mpi_err
53   INTEGER(kind=ip_intwp_p) :: n,nns,iu
54   integer(kind=ip_intwp_p) :: icolor,ikey
55   CHARACTER(len=ic_med)    :: filename,filename2
56   character(len=ic_med)    :: pio_type
57   integer(kind=ip_intwp_p) :: pio_stride
58   integer(kind=ip_intwp_p) :: pio_root
59   integer(kind=ip_intwp_p) :: pio_numtasks
60   INTEGER(kind=ip_intwp_p),ALLOCATABLE :: tmparr(:)
61   INTEGER(kind=ip_intwp_p) :: k,i,m
62   INTEGER(kind=ip_intwp_p) :: nt
63   character(len=ic_field)  :: i_name
64   character(len=*),parameter :: subname = 'oasis_init_comp'
65!  ---------------------------------------------------------
66
67   if (present(kinfo)) then
68      kinfo = OASIS_OK
69   endif
70   call oasis_data_zero()
71
72   !------------------------
73   !--- Initialize MPI
74   !------------------------
75
76   lg_mpiflag = .FALSE.
77   CALL MPI_Initialized ( lg_mpiflag, mpi_err )
78   IF ( .NOT. lg_mpiflag ) THEN
79      if (OASIS_debug >= 0) WRITE (0,FMT='(A)') subname//': Calling MPI_Init'
80      CALL MPI_INIT ( mpi_err )
81   else
82      if (OASIS_debug >= 0) WRITE (0,FMT='(A)') subname//': Not Calling MPI_Init'
83   ENDIF
84
85#ifdef use_comm_MPI1
86   mpi_comm_global = MPI_COMM_WORLD
87#elif defined use_comm_MPI2
88   mpi_comm_global = ??
89#endif
90
91   CALL MPI_Comm_Size(mpi_comm_global,mpi_size_global,mpi_err)
92   CALL MPI_Comm_Rank(mpi_comm_global,mpi_rank_global,mpi_err)
93
94   !------------------------
95   !--- nout file, need mpi_rank_global
96   !------------------------
97
98   iu=-1
99
100   call oasis_unitsetmin(1024)
101   IF (mpi_rank_global == 0) THEN
102       CALL oasis_unitget(iu)
103       nulprt1 = iu
104       WRITE(filename,'(a,i6.6)') 'nout.',mpi_rank_global
105       OPEN(nulprt1,file=filename)
106   ENDIF
107
108   !------------------------
109   !--- Initialize namcouple
110   !--- first on rank 0 to write error messages
111   !--- then on all other ranks
112   !------------------------
113
114   IF (mpi_rank_global == 0) THEN
115      call oasis_namcouple_init()
116   endif
117   call oasis_mpi_barrier(mpi_comm_global)
118   IF (mpi_rank_global /= 0) THEN
119      call oasis_namcouple_init()
120   endif
121   OASIS_debug = namlogprt
122   TIMER_debug = namtlogprt
123
124   ! If NFIELDS=0 there is no coupling
125   ! No information must be written in the debug files as
126   ! the different structures are not allocated
127   !
128   IF ( nnamcpl == 0 ) THEN
129       IF (mpi_rank_global == 0) THEN
130           WRITE (UNIT = nulprt1,FMT = *) '        ***WARNING***'
131           WRITE (UNIT = nulprt1,FMT = *)  &
132              ' The models are not exchanging any field ($NFIELDS = 0) '
133           WRITE (UNIT = nulprt1,FMT = *)  &
134              ' so we force OASIS_debug = 0 for all processors '
135           OASIS_debug = 0
136           CALL oasis_flush(nulprt1)
137       ENDIF
138   ENDIF
139
140   ! Determines the total number of fields to avoid a parameter in oasis_def_var
141   ! and mod_oasis_coupler
142   mvar=0
143   DO nns = 1,nnamcpl
144     n = namfldsort(nns)
145     mvar = mvar + oasis_string_listGetNum(namsrcfld(n))
146   ENDDO
147   IF (mpi_rank_global == 0) THEN
148       WRITE (UNIT = nulprt1,FMT = *) 'Total number of coupling fields :',mvar
149       CALL oasis_flush(nulprt1)
150   ENDIF
151
152   ALLOCATE(prism_var(mvar))
153
154   ! Store all the names of the fields exchanged in the namcouple
155   ! which can be different of namsrcfld(:) and namdstfld(:) if multiple
156   ! fields are exchanged together
157   ALLOCATE(total_namsrcfld(mvar))
158   ALLOCATE(total_namdstfld(mvar))
159   m=0
160   DO nns = 1,nnamcpl
161     n = namfldsort(nns)
162     k=oasis_string_listGetNum(namsrcfld(n))
163     DO i=1,k 
164       m=m+1
165       CALL oasis_string_listGetName(namsrcfld(n),i,i_name)
166       total_namsrcfld(m)=trim(i_name)
167     ENDDO
168   ENDDO
169   !
170   m=0
171   DO nns = 1,nnamcpl
172     n = namfldsort(nns)
173     k=oasis_string_listGetNum(namdstfld(n))
174     DO i=1,k 
175       m=m+1
176       CALL oasis_string_listGetName(namdstfld(n),i,i_name)
177       total_namdstfld(m)=trim(i_name)
178     ENDDO
179   ENDDO
180   DO m=1,mvar
181     IF (mpi_rank_global == 0) THEN
182         WRITE (UNIT = nulprt1,FMT = *) subname,'Coupling fields  namsrcfld:',&
183                                     TRIM(total_namsrcfld(m))
184         WRITE (UNIT = nulprt1,FMT = *) subname,'Coupling fields namdstfld:',&
185                                     TRIM(total_namdstfld(m))
186         CALL oasis_flush(nulprt1)
187     ENDIF
188   ENDDO
189
190   !
191   !------------------------
192   !--- Set compid (need namcouple model names)
193   !------------------------
194
195   compid = -1
196   compnm = trim(cdnam)
197   do n = 1,prism_nmodels
198      if (trim(cdnam) == trim(prism_modnam(n))) compid = n
199   enddo
200   mynummod = compid
201   IF (mpi_rank_global == 0) THEN
202       WRITE(nulprt1,*) subname, 'cdnam :',TRIM(cdnam),' mynummod :',mynummod
203       CALL oasis_flush(nulprt1)
204   ENDIF
205
206   if (compid < 0) then
207       IF (mpi_rank_global == 0) THEN
208           WRITE(nulprt1,*) subname,' model not found in namcouple ',&
209                            TRIM(cdnam)
210           CALL oasis_flush(nulprt1)
211       ENDIF
212       CALL oasis_abort_noarg()
213   endif
214
215
216   !------------------------
217   !--- Re-Set MPI info (need compid for MPI1 COMM_SPLIT)
218   !------------------------
219
220#ifdef use_comm_MPI1
221
222   mpi_comm_global = MPI_COMM_WORLD
223   ikey = compid
224   icolor = compid
225   call MPI_COMM_SPLIT(MPI_COMM_WORLD,icolor,ikey,mpi_comm_local,mpi_err)
226
227#elif defined use_comm_MPI2
228
229   mpi_comm_global = ??
230   mpi_comm_local = MPI_COMM_WORLD
231
232#endif
233
234!------------------------------------
235
236   CALL MPI_Comm_Size(mpi_comm_global,mpi_size_global,mpi_err)
237   CALL MPI_Comm_Rank(mpi_comm_global,mpi_rank_global,mpi_err)
238
239   CALL MPI_Comm_Size(mpi_comm_local,mpi_size_local,mpi_err)
240   CALL MPI_Comm_Rank(mpi_comm_local,mpi_rank_local,mpi_err)
241   mpi_root_local = 0
242
243   !------------------------
244   !--- derive mpi_root_global
245   !------------------------
246
247   allocate(mpi_root_global(prism_nmodels))
248   allocate(tmparr(prism_nmodels))
249   tmparr = -1
250   do n = 1,prism_nmodels
251      if (compid == n .and. &
252          mpi_rank_local == mpi_root_local) then
253         tmparr(n) = mpi_rank_global
254      endif
255   enddo
256   call oasis_mpi_max(tmparr,mpi_root_global,MPI_COMM_WORLD, &
257      string=subname//':mpi_root_global',all=.true.)
258   deallocate(tmparr)
259
260   IF (mpi_rank_global == 0) THEN
261       DO n = 1,prism_nmodels
262         WRITE(nulprt1,*) subname,'   n,prism_model,root = ',&
263            n,TRIM(prism_modnam(n)),mpi_root_global(n)
264       ENDDO
265       CALL oasis_flush(nulprt1)
266   ENDIF
267
268   do n = 1,prism_nmodels
269      IF (mpi_root_global(n) < 0) THEN
270          IF (mpi_rank_global == 0) THEN
271              WRITE(nulprt1,*) subname,'   n,prism_model,root = ',&
272                 n,TRIM(prism_modnam(n)),mpi_root_global(n)
273              WRITE(nulprt1,*) subname,' ERROR: global root invalid, &
274                 & check couplcomm for active tasks'
275              CALL oasis_flush(nulprt1)
276              CALL oasis_abort_noarg()
277          ENDIF
278      ENDIF
279   enddo
280
281#if defined balance
282   ! CPP key balance incompatible with OASIS_Debug < 2
283   IF ( OASIS_debug < 2 ) THEN
284      WRITE (UNIT = nulprt1,FMT = *) '        ***ABORT***'
285      WRITE (UNIT = nulprt1,FMT = *)  &
286       ' With load balance CPP option (-Dbalance) '
287      WRITE (UNIT = nulprt1,FMT = *)  &
288       ' you must define a minimum NLOGPRT = 2 '
289      CALL oasis_flush(nulprt1)
290      CALL oasis_abort_noarg()
291   ENDIF
292#endif
293
294   IF (mpi_rank_global == 0) CLOSE(nulprt1)
295
296   !------------------------
297   !--- debug file
298   !------------------------
299
300   iu=-1
301   CALL oasis_unitget(iu)
302
303       IF (OASIS_debug <= 1) THEN
304           CALL oasis_mpi_bcast(iu,mpi_comm_local,TRIM(subname)//':unit of master',0)
305           IF (mpi_rank_local == 0) THEN
306               nulprt=iu
307               WRITE(filename,'(a,i2.2)') 'debug.root.',compid
308               OPEN(nulprt,file=filename)
309               WRITE(nulprt,*) subname,' OPEN debug file for root pe, unit :',nulprt
310               call oasis_flush(nulprt)
311           ELSE
312               nulprt=iu+mpi_size_global
313               WRITE(filename2,'(a,i2.2)') 'debug_notroot.',compid
314               OPEN(nulprt,file=filename2,position='append')
315!               WRITE(nulprt,*) subname,' OPEN debug file for not root pe, unit :',nulprt
316!               CALL oasis_flush(nulprt)
317           ENDIF
318       ELSE
319           nulprt=iu
320           WRITE(filename,'(a,i2.2,a,i6.6)') 'debug.',compid,'.',mpi_rank_local
321           OPEN(nulprt,file=filename)
322           WRITE(nulprt,*) subname,' OPEN debug file, unit :',nulprt
323           CALL oasis_flush(nulprt)
324       ENDIF
325
326       IF ( (OASIS_debug == 1) .AND. (mpi_rank_local == 0)) OASIS_debug=10
327
328       IF (OASIS_debug >= 2) THEN
329           WRITE(nulprt,*) subname,' model compid ',TRIM(cdnam),compid
330           CALL oasis_flush(nulprt)
331       ENDIF
332
333   call oasis_debug_enter(subname)
334
335   !------------------------
336   !--- PIO
337   !------------------------
338#if (PIO_DEFINED)
339! tcraig, not working as of Oct 2011
340   pio_type = 'netcdf'
341   pio_stride = -99
342   pio_root = -99
343   pio_numtasks = -99
344   call oasis_ioshr_init(mpi_comm_local,pio_type,pio_stride,pio_root,pio_numtasks)
345#endif
346
347   !------------------------
348   !--- Timer Initialization
349   !------------------------
350
351   ! Allocate timer memory based on mvar
352   nt = 7*mvar+30
353   call oasis_timer_init (trim(cdnam), trim(cdnam)//'.timers',nt)
354   call oasis_timer_start('total after init')
355
356   !------------------------
357   !--- Diagnostics
358   !------------------------
359
360   if (OASIS_debug >= 2)  then
361      write(nulprt,*) subname,' compid         = ',compid
362      write(nulprt,*) subname,' compnm         = ',trim(compnm)
363      write(nulprt,*) subname,' mpi_comm_world = ',MPI_COMM_WORLD
364      write(nulprt,*) subname,' mpi_comm_global= ',mpi_comm_global
365      write(nulprt,*) subname,'     size_global= ',mpi_size_global
366      write(nulprt,*) subname,'     rank_global= ',mpi_rank_global
367      write(nulprt,*) subname,' mpi_comm_local = ',mpi_comm_local
368      write(nulprt,*) subname,'     size_local = ',mpi_size_local
369      write(nulprt,*) subname,'     rank_local = ',mpi_rank_local
370      write(nulprt,*) subname,'     root_local = ',mpi_root_local
371      write(nulprt,*) subname,' OASIS_debug    = ',OASIS_debug
372      write(nulprt,*) subname,' prism models: '
373      call oasis_flush(nulprt)
374   endif
375
376   call oasis_debug_exit(subname)
377
378 END SUBROUTINE oasis_init_comp
379
380!----------------------------------------------------------------------
381   SUBROUTINE oasis_terminate(kinfo)
382
383   IMPLICIT NONE
384
385   INTEGER (kind=ip_intwp_p),intent(inout),optional :: kinfo
386!  ---------------------------------------------------------
387   integer(kind=ip_intwp_p) :: mpi_err
388   character(len=*),parameter :: subname = 'oasis_terminate'
389!  ---------------------------------------------------------
390
391   call oasis_debug_enter(subname)
392   if (present(kinfo)) then
393      kinfo = OASIS_OK
394   endif
395
396   call oasis_timer_stop('total after init')
397   call oasis_timer_print()
398
399   call oasis_mpi_barrier(mpi_comm_global)
400   IF ( .NOT. lg_mpiflag ) THEN
401       IF (OASIS_debug >= 2)  THEN
402           WRITE (nulprt,FMT='(A)') subname//': Calling MPI_Finalize'
403           CALL oasis_flush(nulprt)
404       ENDIF
405       CALL MPI_Finalize ( mpi_err )
406   else
407       IF (OASIS_debug >= 2)  THEN
408           WRITE (nulprt,FMT='(A)') subname//': Not Calling MPI_Finalize'
409           CALL oasis_flush(nulprt)
410       ENDIF
411   ENDIF
412
413   IF (mpi_rank_local == 0)  THEN
414       WRITE(nulprt,*) subname,' SUCCESSFUL RUN'
415       CALL oasis_flush(nulprt)
416   ENDIF
417
418   call oasis_debug_exit(subname)
419
420 END SUBROUTINE oasis_terminate
421
422!----------------------------------------------------------------------
423   SUBROUTINE oasis_get_localcomm(localcomm,kinfo)
424
425   IMPLICIT NONE
426
427   INTEGER (kind=ip_intwp_p),intent(out)   :: localcomm
428   INTEGER (kind=ip_intwp_p),intent(inout),optional :: kinfo
429!  ---------------------------------------------------------
430   character(len=*),parameter :: subname = 'oasis_get_localcomm'
431!  ---------------------------------------------------------
432
433   call oasis_debug_enter(subname)
434   if (present(kinfo)) then
435      kinfo = OASIS_OK
436   endif
437
438   ! from prism_data
439   localcomm = mpi_comm_local
440   IF (OASIS_debug >= 2) THEN
441       WRITE(nulprt,*) 'localcomm :',localcomm
442       CALL oasis_FLUSH(nulprt)
443   ENDIF
444
445   call oasis_debug_exit(subname)
446
447 END SUBROUTINE oasis_get_localcomm
448!----------------------------------------------------------------------
449   SUBROUTINE oasis_set_couplcomm(localcomm,kinfo)
450
451   IMPLICIT NONE
452
453   INTEGER (kind=ip_intwp_p),intent(in)   :: localcomm
454   INTEGER (kind=ip_intwp_p),intent(inout),optional :: kinfo
455!  ---------------------------------------------------------
456   character(len=*),parameter :: subname = 'oasis_set_couplcomm'
457!  ---------------------------------------------------------
458
459   call oasis_debug_enter(subname)
460   if (present(kinfo)) then
461      kinfo = OASIS_OK
462   endif
463
464   !------------------------
465   !--- update mpi_comm_local from component
466   !------------------------
467
468   mpi_comm_local = localcomm
469
470   !------------------------
471   !--- and now update necessary info
472   !------------------------
473
474   mpi_size_local = -1
475   mpi_rank_local = -1
476   if (mpi_comm_local /= MPI_COMM_NULL) then
477      CALL MPI_Comm_Size(mpi_comm_local,mpi_size_local,mpi_err)
478      CALL MPI_Comm_Rank(mpi_comm_local,mpi_rank_local,mpi_err)
479      mpi_root_local = 0
480   endif
481
482   call oasis_debug_exit(subname)
483
484 END SUBROUTINE oasis_set_couplcomm
485!----------------------------------------------------------------------
486   SUBROUTINE oasis_create_couplcomm(icpl,allcomm,cplcomm,kinfo)
487
488   IMPLICIT NONE
489
490   INTEGER (kind=ip_intwp_p),intent(in)   :: icpl
491   INTEGER (kind=ip_intwp_p),intent(in)   :: allcomm
492   INTEGER (kind=ip_intwp_p),intent(out)  :: cplcomm
493   INTEGER (kind=ip_intwp_p),intent(inout),optional :: kinfo
494!  ---------------------------------------------------------
495   integer(kind=ip_intwp_p) :: mpi_err
496   character(len=*),parameter :: subname = 'oasis_create_couplcomm'
497!  ---------------------------------------------------------
498
499   call oasis_debug_enter(subname)
500   if (present(kinfo)) then
501      kinfo = OASIS_OK
502   endif
503
504   !------------------------
505   !--- generate cplcomm from allcomm and icpl
506   !------------------------
507
508   CALL MPI_COMM_Split(allcomm,icpl,1,cplcomm,mpi_err)
509   IF (mpi_err /= 0) THEN
510      WRITE (nulprt,*) subname,' ERROR: MPI_Comm_Split abort ',mpi_err
511      CALL oasis_flush(nulprt)
512      call oasis_abort_noarg()
513   ENDIF
514
515   !------------------------
516   !--- update mpi_comm_local from component
517   !------------------------
518
519   call oasis_set_couplcomm(cplcomm)
520
521   IF (OASIS_debug >= 2)  THEN
522       WRITE (nulprt,*) 'New local coupling comm =',cplcomm
523       CALL oasis_flush(nulprt)
524   ENDIF
525
526   call oasis_debug_exit(subname)
527
528 END SUBROUTINE oasis_create_couplcomm
529!----------------------------------------------------------------------
530   SUBROUTINE oasis_get_debug(debug,kinfo)
531
532   IMPLICIT NONE
533
534   INTEGER (kind=ip_intwp_p),intent(out)   :: debug
535   INTEGER (kind=ip_intwp_p),intent(inout),optional :: kinfo
536!  ---------------------------------------------------------
537   character(len=*),parameter :: subname = 'oasis_get_debug'
538!  ---------------------------------------------------------
539
540   call oasis_debug_enter(subname)
541   if (present(kinfo)) then
542      kinfo = OASIS_OK
543   endif
544
545   debug = OASIS_debug
546
547   call oasis_debug_exit(subname)
548
549 END SUBROUTINE oasis_get_debug
550!----------------------------------------------------------------------
551   SUBROUTINE oasis_set_debug(debug,kinfo)
552
553   IMPLICIT NONE
554
555   INTEGER (kind=ip_intwp_p),intent(in)   :: debug
556   INTEGER (kind=ip_intwp_p),intent(inout),optional :: kinfo
557!  ---------------------------------------------------------
558   character(len=*),parameter :: subname = 'oasis_set_debug'
559!  ---------------------------------------------------------
560
561   call oasis_debug_enter(subname)
562   if (present(kinfo)) then
563      kinfo = OASIS_OK
564   endif
565
566   OASIS_debug = debug
567   if (OASIS_debug >= 2) then
568      write(nulprt,*) subname,' set OASIS_debug to ',OASIS_debug
569      CALL oasis_flush(nulprt)
570   endif
571
572   call oasis_debug_exit(subname)
573
574 END SUBROUTINE oasis_set_debug
575!----------------------------------------------------------------------
576   SUBROUTINE oasis_get_intercomm(new_comm, cdnam, kinfo)
577
578   IMPLICIT NONE
579
580   INTEGER (kind=ip_intwp_p),intent(out) :: new_comm
581   CHARACTER(len=*),intent(in) :: cdnam
582   INTEGER (kind=ip_intwp_p),intent(out),optional :: kinfo
583
584   INTEGER (kind=ip_intwp_p)    :: n, il, ierr, tag
585   LOGICAL :: found
586!  ---------------------------------------------------------
587   character(len=*),parameter :: subname = 'oasis_get_intercomm'
588!  ---------------------------------------------------------
589
590   call oasis_debug_enter(subname)
591   if (present(kinfo)) then
592      kinfo = OASIS_OK
593   endif
594
595   found = .false.
596   do n = 1,prism_nmodels
597      if (trim(cdnam) == trim(prism_modnam(n))) then
598         if (found) then
599            write(nulprt,*) subname,' ERROR: found same model name twice'
600            WRITE(nulprt,*) subname,' abort by model :',compid,&
601            ' proc :',mpi_rank_local
602            CALL oasis_flush(nulprt)
603            call oasis_abort_noarg()
604         endif
605         il = n
606         found = .true.
607      endif
608   enddo
609
610   if (.not. found) then
611      write(nulprt,*) subname,' ERROR: input model name not found'
612      WRITE(nulprt,*) subname,' abort by model :',compid,&
613      ' proc :',mpi_rank_local
614      CALL oasis_flush(nulprt)
615      call oasis_abort_noarg()
616   endif
617
618   IF (OASIS_debug >= 2) THEN
619       WRITE(nulprt,*) subname, 'cdnam :',cdnam,' il :',il, &
620                       'mpi_root_global(il) :',mpi_root_global(il),&
621                       'mpi_comm_local :',mpi_comm_local
622       CALL oasis_flush(nulprt)
623   ENDIF
624
625   tag=ICHAR(TRIM(compnm))+ICHAR(TRIM(cdnam))
626   CALL mpi_intercomm_create(mpi_comm_local, 0, MPI_COMM_WORLD, &
627                             mpi_root_global(il), tag, new_comm, ierr)
628
629   call oasis_debug_exit(subname)
630
631 END SUBROUTINE oasis_get_intercomm
632!----------------------------------------------------------------------
633   SUBROUTINE oasis_get_intracomm(new_comm, cdnam, kinfo)
634
635   IMPLICIT NONE
636
637   INTEGER (kind=ip_intwp_p),intent(out) :: new_comm
638   CHARACTER(len=*),intent(in) :: cdnam
639   INTEGER (kind=ip_intwp_p),intent(out),optional :: kinfo
640
641   INTEGER (kind=ip_intwp_p)    :: tmp_intercomm
642   INTEGER (kind=ip_intwp_p)    :: ierr
643!  ---------------------------------------------------------
644   character(len=*),parameter :: subname = 'oasis_get_intracomm'
645!  ---------------------------------------------------------
646
647   call oasis_debug_enter(subname)
648   if (present(kinfo)) then
649      kinfo = OASIS_OK
650   endif
651
652   call oasis_get_intercomm(tmp_intercomm, cdnam, kinfo)
653
654   CALL mpi_intercomm_merge(tmp_intercomm,.FALSE., new_comm, ierr)
655
656   call oasis_debug_exit(subname)
657
658 END SUBROUTINE oasis_get_intracomm
659!----------------------------------------------------------------------
660   SUBROUTINE oasis_enddef(kinfo)
661
662   IMPLICIT NONE
663
664   INTEGER (kind=ip_intwp_p),intent(inout),optional :: kinfo
665!  ---------------------------------------------------------
666   integer (kind=ip_intwp_p) :: n
667   integer (kind=ip_intwp_p) :: lkinfo
668   character(len=*),parameter :: subname = 'oasis_enddef'
669!  ---------------------------------------------------------
670
671   call oasis_debug_enter(subname)
672   lkinfo = OASIS_OK
673
674   !------------------------
675   !--- write grid info to files one model at a time
676   !------------------------
677
678   do n = 1,prism_nmodels
679      if (compid == n .and. mpi_rank_local == mpi_root_local) then
680         call oasis_write2files()
681      endif
682      call oasis_mpi_barrier(mpi_comm_global)
683   enddo
684
685   !------------------------
686   !--- MCT Initialization
687   !------------------------
688
689   call mct_world_init(prism_nmodels,mpi_comm_global,mpi_comm_local,compid)
690   IF (OASIS_debug >= 2)  THEN
691      WRITE(nulprt,*) subname, ' done mct_world_init '
692      CALL oasis_flush(nulprt)
693   ENDIF
694
695   call oasis_coupler_setup()
696   IF (OASIS_debug >= 2)  THEN
697      WRITE(nulprt,*) subname, ' done prism_coupler_setup '
698      CALL oasis_flush(nulprt)
699   ENDIF
700
701   if (mpi_comm_local /= MPI_COMM_NULL) then
702      call oasis_advance_init(lkinfo)
703      IF (OASIS_debug >= 2)  THEN
704         WRITE(nulprt,*) subname, ' done prism_advance_init '
705         CALL oasis_flush(nulprt)
706      ENDIF
707   endif
708
709   !--- Force OASIS_OK here rather than anything else ---
710
711   if (present(kinfo)) then
712      kinfo = OASIS_OK
713   endif
714
715   call oasis_debug_exit(subname)
716
717 END SUBROUTINE oasis_enddef
718!----------------------------------------------------------------------
719
720END MODULE mod_oasis_method
Note: See TracBrowser for help on using the repository browser.