New URL for NEMO forge! http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

cpl_oasis3.F90 in branches/UKMO/nemo_v3_6_STABLE_pkg/NEMOGCM/NEMO/OPA_SRC/SBC – NEMO

Context Navigation

source: branches/UKMO/nemo_v3_6_STABLE_pkg/NEMOGCM/NEMO/OPA_SRC/SBC/cpl_oasis3.F90 @ 6254

Last change on this file since 6254 was 6254, checked in by frrh, 8 years ago

Merge branches/UKMO/dev_r5107_hadgem3_mct@5679 (not 5631 as used in
original GO6.1 which I was supplied with! This has extra, meaningful,
error trapping in place of the original inappropriate use of "STOP"
which is useless in the context of coupled models.

Again merging this branch proved far more awkward than it should
be with spurious claims of conflicts in various irrelevant files
in NEMOGCM/ARCH/ and DOC/TexFiles which I reverted before committing.

File size: 28.7 KB

Rev	Line
[532]	1	MODULE cpl_oasis3
	2	!!======================================================================
	3	!! * MODULE cpl_oasis *
[4990]	4	!! Coupled O/A : coupled ocean-atmosphere case using OASIS3-MCT
[532]	5	!!=====================================================================
	6	!! History :
[2715]	7	!! 9.0 ! 04-06 (R. Redler, NEC Laboratories Europe, Germany) Original code
	8	!! " " ! 04-11 (R. Redler, NEC Laboratories Europe; N. Keenlyside, W. Park, IFM-GEOMAR, Germany) revision
[532]	9	!! " " ! 04-11 (V. Gayler, MPI M&D) Grid writing
	10	!! " " ! 05-08 (R. Redler, W. Park) frld initialization, paral(2) revision
	11	!! " " ! 05-09 (R. Redler) extended to allow for communication over root only
	12	!! " " ! 06-01 (W. Park) modification of physical part
	13	!! " " ! 06-02 (R. Redler, W. Park) buffer array fix for root exchange
[3294]	14	!! 3.4 ! 11-11 (C. Harris) Changes to allow mutiple category fields
[532]	15	!!----------------------------------------------------------------------
	16	!!----------------------------------------------------------------------
[5407]	17	!! 'key_oasis3' coupled Ocean/Atmosphere via OASIS3-MCT
	18	!! 'key_oa3mct_v3' to be added for OASIS3-MCT version 3
[532]	19	!!----------------------------------------------------------------------
[4990]	20	!! cpl_init : initialization of coupled mode communication
	21	!! cpl_define : definition of grid and fields
	22	!! cpl_snd : snd out fields in coupled mode
	23	!! cpl_rcv : receive fields in coupled mode
	24	!! cpl_finalize : finalize the coupled mode communication
[532]	25	!!----------------------------------------------------------------------
[6254]	26	#if defined key_oasis3 \|\| defined key_oasis3mct
[4990]	27	USE mod_oasis ! OASIS3-MCT module
	28	#endif
[1218]	29	USE par_oce ! ocean parameters
[532]	30	USE dom_oce ! ocean space and time domain
	31	USE in_out_manager ! I/O manager
[2715]	32	USE lbclnk ! ocean lateral boundary conditions (or mpp link)
[6254]	33
	34	#if defined key_cpl_rootexchg
	35	USE lib_mpp, only : mppsync
	36	USE lib_mpp, only : mppscatter,mppgather
	37	#endif
[2715]	38
[532]	39	IMPLICIT NONE
[1218]	40	PRIVATE
[532]	41
[4990]	42	PUBLIC cpl_init
	43	PUBLIC cpl_define
	44	PUBLIC cpl_snd
	45	PUBLIC cpl_rcv
	46	PUBLIC cpl_freq
	47	PUBLIC cpl_finalize
[6254]	48	#if defined key_mpp_mpi
	49	INCLUDE 'mpif.h'
	50	#endif
	51
	52	INTEGER, PARAMETER :: localRoot = 0
	53	LOGICAL :: commRank ! true for ranks doing OASIS communication
	54	#if defined key_cpl_rootexchg
	55	LOGICAL :: rootexchg =.true. ! logical switch
	56	#else
	57	LOGICAL :: rootexchg =.false. ! logical switch
	58	#endif
[2715]	59
	60	INTEGER, PUBLIC :: OASIS_Rcv = 1 !: return code if received field
	61	INTEGER, PUBLIC :: OASIS_idle = 0 !: return code if nothing done by oasis
[4990]	62	INTEGER :: ncomp_id ! id returned by oasis_init_comp
[2715]	63	INTEGER :: nerror ! return error code
[6254]	64	#if ! defined key_oasis3 && ! defined key_oasis3mct
[4990]	65	! OASIS Variables not used. defined only for compilation purpose
	66	INTEGER :: OASIS_Out = -1
	67	INTEGER :: OASIS_REAL = -1
	68	INTEGER :: OASIS_Ok = -1
	69	INTEGER :: OASIS_In = -1
	70	INTEGER :: OASIS_Sent = -1
	71	INTEGER :: OASIS_SentOut = -1
	72	INTEGER :: OASIS_ToRest = -1
	73	INTEGER :: OASIS_ToRestOut = -1
	74	INTEGER :: OASIS_Recvd = -1
	75	INTEGER :: OASIS_RecvOut = -1
	76	INTEGER :: OASIS_FromRest = -1
	77	INTEGER :: OASIS_FromRestOut = -1
	78	#endif
[2715]	79
[5407]	80	INTEGER :: nrcv ! total number of fields received
	81	INTEGER :: nsnd ! total number of fields sent
	82	INTEGER :: ncplmodel ! Maximum number of models to/from which NEMO is potentialy sending/receiving data
	83	INTEGER, PUBLIC, PARAMETER :: nmaxfld=50 ! Maximum number of coupling fields
[4990]	84	INTEGER, PUBLIC, PARAMETER :: nmaxcat=5 ! Maximum number of coupling fields
	85	INTEGER, PUBLIC, PARAMETER :: nmaxcpl=5 ! Maximum number of coupling fields
[1218]	86
[3294]	87	TYPE, PUBLIC :: FLD_CPL !: Type for coupling field information
	88	LOGICAL :: laction ! To be coupled or not
	89	CHARACTER(len = 8) :: clname ! Name of the coupling field
	90	CHARACTER(len = 1) :: clgrid ! Grid type
	91	REAL(wp) :: nsgn ! Control of the sign change
[4990]	92	INTEGER, DIMENSION(nmaxcat,nmaxcpl) :: nid ! Id of the field (no more than 9 categories and 9 extrena models)
[3294]	93	INTEGER :: nct ! Number of categories in field
[4990]	94	INTEGER :: ncplmodel ! Maximum number of models to/from which this variable may be sent/received
[1218]	95	END TYPE FLD_CPL
[532]	96
[2715]	97	TYPE(FLD_CPL), DIMENSION(nmaxfld), PUBLIC :: srcv, ssnd !: Coupling fields
[532]	98
[2715]	99	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: exfld ! Temporary buffer for receiving
[6254]	100	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: tbuf ! Temporary buffer for sending / receiving
	101	INTEGER, PUBLIC :: localComm
	102
[532]	103	!!----------------------------------------------------------------------
[2528]	104	!! NEMO/OPA 3.3 , NEMO Consortium (2010)
	105	!! $Id$
[2715]	106	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
[532]	107	!!----------------------------------------------------------------------
	108	CONTAINS
	109
[5407]	110	SUBROUTINE cpl_init( cd_modname, kl_comm )
[532]	111	!!-------------------------------------------------------------------
[4990]	112	!! * ROUTINE cpl_init *
[532]	113	!!
	114	!! ** Purpose : Initialize coupled mode communication for ocean
	115	!! exchange between AGCM, OGCM and COUPLER. (OASIS3 software)
	116	!!
	117	!! ** Method : OASIS3 MPI communication
	118	!!--------------------------------------------------------------------
[5407]	119	CHARACTER(len = *), INTENT(in) :: cd_modname ! model name as set in namcouple file
	120	INTEGER , INTENT(out) :: kl_comm ! local communicator of the model
[1226]	121	!!--------------------------------------------------------------------
[1218]	122
[1579]	123	! WARNING: No write in numout in this routine
	124	!============================================
	125
[532]	126	!------------------------------------------------------------------
[4990]	127	! 1st Initialize the OASIS system for the application
[532]	128	!------------------------------------------------------------------
[5407]	129	CALL oasis_init_comp ( ncomp_id, TRIM(cd_modname), nerror )
[4990]	130	IF ( nerror /= OASIS_Ok ) &
	131	CALL oasis_abort (ncomp_id, 'cpl_init', 'Failure in oasis_init_comp')
[532]	132
	133	!------------------------------------------------------------------
	134	! 3rd Get an MPI communicator for OPA local communication
	135	!------------------------------------------------------------------
	136
[4990]	137	CALL oasis_get_localcomm ( kl_comm, nerror )
	138	IF ( nerror /= OASIS_Ok ) &
	139	CALL oasis_abort (ncomp_id, 'cpl_init','Failure in oasis_get_localcomm' )
[6254]	140	localComm = kl_comm
[2715]	141	!
[4990]	142	END SUBROUTINE cpl_init
[532]	143
	144
[4990]	145	SUBROUTINE cpl_define( krcv, ksnd, kcplmodel )
[532]	146	!!-------------------------------------------------------------------
[4990]	147	!! * ROUTINE cpl_define *
[532]	148	!!
	149	!! ** Purpose : Define grid and field information for ocean
	150	!! exchange between AGCM, OGCM and COUPLER. (OASIS3 software)
	151	!!
	152	!! ** Method : OASIS3 MPI communication
	153	!!--------------------------------------------------------------------
[2715]	154	INTEGER, INTENT(in) :: krcv, ksnd ! Number of received and sent coupling fields
[4990]	155	INTEGER, INTENT(in) :: kcplmodel ! Maximum number of models to/from which NEMO is potentialy sending/receiving data
[1226]	156	!
[2715]	157	INTEGER :: id_part
	158	INTEGER :: paral(5) ! OASIS3 box partition
	159	INTEGER :: ishape(2,2) ! shape of arrays passed to PSMILe
[4990]	160	INTEGER :: ji,jc,jm ! local loop indicees
	161	CHARACTER(LEN=64) :: zclname
	162	CHARACTER(LEN=2) :: cli2
[532]	163	!!--------------------------------------------------------------------
[1218]	164
[532]	165	IF(lwp) WRITE(numout,*)
[4990]	166	IF(lwp) WRITE(numout,*) 'cpl_define : initialization in coupled ocean/atmosphere case'
[532]	167	IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~'
	168	IF(lwp) WRITE(numout,*)
[6254]	169
	170	commRank = .false.
	171	IF ( rootexchg ) THEN
	172	IF ( nproc == localRoot ) commRank = .true.
	173	ELSE
	174	commRank = .true.
	175	ENDIF
[532]	176
[5407]	177	ncplmodel = kcplmodel
[4990]	178	IF( kcplmodel > nmaxcpl ) THEN
[5407]	179	CALL oasis_abort ( ncomp_id, 'cpl_define', 'ncplmodel is larger than nmaxcpl, increase nmaxcpl') ; RETURN
[4990]	180	ENDIF
[5407]	181
	182	nrcv = krcv
	183	IF( nrcv > nmaxfld ) THEN
	184	CALL oasis_abort ( ncomp_id, 'cpl_define', 'nrcv is larger than nmaxfld, increase nmaxfld') ; RETURN
	185	ENDIF
	186
	187	nsnd = ksnd
	188	IF( nsnd > nmaxfld ) THEN
	189	CALL oasis_abort ( ncomp_id, 'cpl_define', 'nsnd is larger than nmaxfld, increase nmaxfld') ; RETURN
	190	ENDIF
	191
[532]	192	!
	193	! ... Define the shape for the area that excludes the halo
	194	! For serial configuration (key_mpp_mpi not being active)
	195	! nl* is set to the global values 1 and jp*glo.
	196	!
[1218]	197	ishape(:,1) = (/ 1, nlei-nldi+1 /)
	198	ishape(:,2) = (/ 1, nlej-nldj+1 /)
[532]	199	!
	200	!
[1218]	201	! -----------------------------------------------------------------
	202	! ... Define the partition
	203	! -----------------------------------------------------------------
	204
[6254]	205	IF ( rootexchg ) THEN
	206
	207	paral(1) = 2 ! box partitioning
	208	paral(2) = 0 ! NEMO lower left corner global offset
	209	paral(3) = jpiglo ! local extent in i
	210	paral(4) = jpjglo ! local extent in j
	211	paral(5) = jpiglo ! global extent in x
	212
	213	ELSE
	214
[1218]	215	paral(1) = 2 ! box partitioning
	216	paral(2) = jpiglo * (nldj-1+njmpp-1) + (nldi-1+nimpp-1) ! NEMO lower left corner global offset
	217	paral(3) = nlei-nldi+1 ! local extent in i
	218	paral(4) = nlej-nldj+1 ! local extent in j
	219	paral(5) = jpiglo ! global extent in x
	220
	221	IF( ln_ctl ) THEN
	222	WRITE(numout,*) ' multiexchg: paral (1:5)', paral
	223	WRITE(numout,*) ' multiexchg: jpi, jpj =', jpi, jpj
	224	WRITE(numout,*) ' multiexchg: nldi, nlei, nimpp =', nldi, nlei, nimpp
	225	WRITE(numout,*) ' multiexchg: nldj, nlej, njmpp =', nldj, nlej, njmpp
	226	ENDIF
	227
[6254]	228	ENDIF
	229	IF ( commRank ) CALL oasis_def_partition ( id_part, paral, nerror )
	230
	231	! ... Allocate memory for data exchange
[532]	232	!
[6254]	233	ALLOCATE(exfld(paral(3), paral(4)), stat = nerror)
	234	IF( nerror > 0 ) THEN
	235	CALL oasis_abort ( ncomp_id, 'cpl_define', 'Failure in allocating exfld') ; RETURN
	236	ENDIF
	237	IF ( rootexchg ) THEN
	238	! Should possibly use one of the work arrays for tbuf really
	239	ALLOCATE(tbuf(jpi, jpj, jpnij), stat = nerror)
	240	IF( nerror > 0 ) THEN
	241	CALL oasis_abort ( ncomp_id, 'cpl_define', 'Failure in allocating tbuf') ; RETURN
	242	ENDIF
	243	ENDIF
	244	!
	245	IF (commRank ) THEN
	246	!
[1218]	247	! ... Announce send variables.
[532]	248	!
[4990]	249	ssnd(:)%ncplmodel = kcplmodel
	250	!
[1226]	251	DO ji = 1, ksnd
[4990]	252	IF ( ssnd(ji)%laction ) THEN
	253
	254	IF( ssnd(ji)%nct > nmaxcat ) THEN
	255	CALL oasis_abort ( ncomp_id, 'cpl_define', 'Number of categories of '// &
	256	& TRIM(ssnd(ji)%clname)//' is larger than nmaxcat, increase nmaxcat' )
	257	RETURN
	258	ENDIF
	259
[3294]	260	DO jc = 1, ssnd(ji)%nct
[4990]	261	DO jm = 1, kcplmodel
	262
	263	IF ( ssnd(ji)%nct .GT. 1 ) THEN
	264	WRITE(cli2,'(i2.2)') jc
	265	zclname = TRIM(ssnd(ji)%clname)//'_cat'//cli2
	266	ELSE
	267	zclname = ssnd(ji)%clname
	268	ENDIF
	269	IF ( kcplmodel > 1 ) THEN
	270	WRITE(cli2,'(i2.2)') jm
	271	zclname = 'model'//cli2//'_'//TRIM(zclname)
	272	ENDIF
	273	#if defined key_agrif
	274	IF( agrif_fixed() /= 0 ) THEN
	275	zclname=TRIM(Agrif_CFixed())//'_'//TRIM(zclname)
	276	END IF
	277	#endif
	278	IF( ln_ctl ) WRITE(numout,*) "Define", ji, jc, jm, " "//TRIM(zclname), " for ", OASIS_Out
	279	CALL oasis_def_var (ssnd(ji)%nid(jc,jm), zclname, id_part , (/ 2, 0 /), &
	280	& OASIS_Out , ishape , OASIS_REAL, nerror )
	281	IF ( nerror /= OASIS_Ok ) THEN
	282	WRITE(numout,*) 'Failed to define transient ', ji, jc, jm, " "//TRIM(zclname)
	283	CALL oasis_abort ( ssnd(ji)%nid(jc,jm), 'cpl_define', 'Failure in oasis_def_var' )
	284	ENDIF
	285	IF( ln_ctl .AND. ssnd(ji)%nid(jc,jm) /= -1 ) WRITE(numout,*) "variable defined in the namcouple"
	286	IF( ln_ctl .AND. ssnd(ji)%nid(jc,jm) == -1 ) WRITE(numout,*) "variable NOT defined in the namcouple"
	287	END DO
[3294]	288	END DO
[1218]	289	ENDIF
[6254]	290	END DO
[1218]	291	!
	292	! ... Announce received variables.
	293	!
[4990]	294	srcv(:)%ncplmodel = kcplmodel
	295	!
[1226]	296	DO ji = 1, krcv
[1218]	297	IF ( srcv(ji)%laction ) THEN
[4990]	298
	299	IF( srcv(ji)%nct > nmaxcat ) THEN
	300	CALL oasis_abort ( ncomp_id, 'cpl_define', 'Number of categories of '// &
	301	& TRIM(srcv(ji)%clname)//' is larger than nmaxcat, increase nmaxcat' )
	302	RETURN
	303	ENDIF
	304
[3294]	305	DO jc = 1, srcv(ji)%nct
[4990]	306	DO jm = 1, kcplmodel
	307
	308	IF ( srcv(ji)%nct .GT. 1 ) THEN
	309	WRITE(cli2,'(i2.2)') jc
	310	zclname = TRIM(srcv(ji)%clname)//'_cat'//cli2
	311	ELSE
	312	zclname = srcv(ji)%clname
	313	ENDIF
	314	IF ( kcplmodel > 1 ) THEN
	315	WRITE(cli2,'(i2.2)') jm
	316	zclname = 'model'//cli2//'_'//TRIM(zclname)
	317	ENDIF
	318	#if defined key_agrif
	319	IF( agrif_fixed() /= 0 ) THEN
	320	zclname=TRIM(Agrif_CFixed())//'_'//TRIM(zclname)
	321	END IF
	322	#endif
	323	IF( ln_ctl ) WRITE(numout,*) "Define", ji, jc, jm, " "//TRIM(zclname), " for ", OASIS_In
	324	CALL oasis_def_var (srcv(ji)%nid(jc,jm), zclname, id_part , (/ 2, 0 /), &
	325	& OASIS_In , ishape , OASIS_REAL, nerror )
	326	IF ( nerror /= OASIS_Ok ) THEN
	327	WRITE(numout,*) 'Failed to define transient ', ji, jc, jm, " "//TRIM(zclname)
	328	CALL oasis_abort ( srcv(ji)%nid(jc,jm), 'cpl_define', 'Failure in oasis_def_var' )
	329	ENDIF
	330	IF( ln_ctl .AND. srcv(ji)%nid(jc,jm) /= -1 ) WRITE(numout,*) "variable defined in the namcouple"
	331	IF( ln_ctl .AND. srcv(ji)%nid(jc,jm) == -1 ) WRITE(numout,*) "variable NOT defined in the namcouple"
	332
	333	END DO
[3294]	334	END DO
[1218]	335	ENDIF
	336	END DO
[6254]	337	!
	338	ENDIF ! commRank=true
[1218]	339
[532]	340	!------------------------------------------------------------------
[1218]	341	! End of definition phase
[532]	342	!------------------------------------------------------------------
[1218]	343
[6254]	344	IF ( commRank ) THEN
	345
	346	CALL oasis_enddef(nerror)
	347	IF( nerror /= OASIS_Ok ) CALL oasis_abort ( ncomp_id, 'cpl_define', 'Failure in oasis_enddef')
	348	ENDIF
[2715]	349	!
[4990]	350	END SUBROUTINE cpl_define
[1218]	351
	352
[4990]	353	SUBROUTINE cpl_snd( kid, kstep, pdata, kinfo )
[532]	354	!!---------------------------------------------------------------------
[4990]	355	!! * ROUTINE cpl_snd *
[532]	356	!!
	357	!! ** Purpose : - At each coupling time-step,this routine sends fields
	358	!! like sst or ice cover to the coupler or remote application.
	359	!!----------------------------------------------------------------------
[3294]	360	INTEGER , INTENT(in ) :: kid ! variable index in the array
	361	INTEGER , INTENT( out) :: kinfo ! OASIS3 info argument
	362	INTEGER , INTENT(in ) :: kstep ! ocean time-step in seconds
	363	REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdata
	364	!!
[6254]	365	INTEGER :: jn,jc,jm ! local loop index
[532]	366	!!--------------------------------------------------------------------
	367	!
[1218]	368	! snd data to OASIS3
[532]	369	!
[3294]	370	DO jc = 1, ssnd(kid)%nct
[4990]	371	DO jm = 1, ssnd(kid)%ncplmodel
	372
	373	IF( ssnd(kid)%nid(jc,jm) /= -1 ) THEN
[6254]	374	IF ( rootexchg ) THEN
	375	!
	376	! collect data on the local root process
	377	!
	378	CALL mppgather (pdata(:,:,jc),localRoot,tbuf)
	379	CALL mppsync
	380
	381	IF ( nproc == localRoot ) THEN
	382
	383	DO jn = 1, jpnij
	384	exfld(nimppt(jn)-1+nldit(jn):nimppt(jn)+nleit(jn)-1,njmppt(jn)-1+nldjt(jn):njmppt(jn)+nlejt(jn)-1)= &
	385	tbuf(nldit(jn):nleit(jn),nldjt(jn):nlejt(jn),jn)
	386	ENDDO
[4990]	387
[6254]	388	! snd data to OASIS3
	389	CALL oasis_put ( ssnd(kid)%nid(jc,jm), kstep, exfld, kinfo )
	390
	391	ENDIF
	392
	393	ELSE
	394
	395	! snd data to OASIS3
	396	CALL oasis_put ( ssnd(kid)%nid(jc,jm), kstep, pdata(nldi:nlei, nldj:nlej,jc), kinfo )
	397	ENDIF
	398
[4990]	399	IF ( ln_ctl ) THEN
	400	IF ( kinfo == OASIS_Sent .OR. kinfo == OASIS_ToRest .OR. &
	401	& kinfo == OASIS_SentOut .OR. kinfo == OASIS_ToRestOut ) THEN
	402	WRITE(numout,) '***************'
	403	WRITE(numout,*) 'oasis_put: Outgoing ', ssnd(kid)%clname
	404	WRITE(numout,*) 'oasis_put: ivarid ', ssnd(kid)%nid(jc,jm)
	405	WRITE(numout,*) 'oasis_put: kstep ', kstep
	406	WRITE(numout,*) 'oasis_put: info ', kinfo
	407	WRITE(numout,*) ' - Minimum value is ', MINVAL(pdata(:,:,jc))
	408	WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata(:,:,jc))
	409	WRITE(numout,*) ' - Sum value is ', SUM(pdata(:,:,jc))
	410	WRITE(numout,) '***************'
	411	ENDIF
	412	ENDIF
	413
[3294]	414	ENDIF
[4990]	415
	416	ENDDO
[3294]	417	ENDDO
[2715]	418	!
[4990]	419	END SUBROUTINE cpl_snd
[532]	420
	421
[4990]	422	SUBROUTINE cpl_rcv( kid, kstep, pdata, pmask, kinfo )
[532]	423	!!---------------------------------------------------------------------
[4990]	424	!! * ROUTINE cpl_rcv *
[532]	425	!!
	426	!! ** Purpose : - At each coupling time-step,this routine receives fields
	427	!! like stresses and fluxes from the coupler or remote application.
	428	!!----------------------------------------------------------------------
[3294]	429	INTEGER , INTENT(in ) :: kid ! variable index in the array
	430	INTEGER , INTENT(in ) :: kstep ! ocean time-step in seconds
	431	REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pdata ! IN to keep the value if nothing is done
[4990]	432	REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pmask ! coupling mask
[3294]	433	INTEGER , INTENT( out) :: kinfo ! OASIS3 info argument
[532]	434	!!
[6254]	435	INTEGER :: jn,jc,jm ! local loop index
[4990]	436	LOGICAL :: llaction, llfisrt
[1218]	437	!!--------------------------------------------------------------------
[532]	438	!
[1218]	439	! receive local data from OASIS3 on every process
	440	!
[4990]	441	kinfo = OASIS_idle
	442	!
[3294]	443	DO jc = 1, srcv(kid)%nct
[4990]	444	llfisrt = .TRUE.
[532]	445
[4990]	446	DO jm = 1, srcv(kid)%ncplmodel
	447
	448	IF( srcv(kid)%nid(jc,jm) /= -1 ) THEN
	449
[6254]	450	!
	451	! receive data from OASIS3
	452	!
	453	IF ( commRank ) CALL oasis_get ( srcv(kid)%nid(jc,jm), kstep, exfld, kinfo )
	454
	455	IF ( rootexchg ) CALL MPI_BCAST ( kinfo, 1, MPI_INTEGER, localRoot, localComm, nerror )
	456
[4990]	457	llaction = kinfo == OASIS_Recvd .OR. kinfo == OASIS_FromRest .OR. &
	458	& kinfo == OASIS_RecvOut .OR. kinfo == OASIS_FromRestOut
	459
	460	IF ( ln_ctl ) WRITE(numout,*) "llaction, kinfo, kstep, ivarid: " , llaction, kinfo, kstep, srcv(kid)%nid(jc,jm)
	461
	462	IF ( llaction ) THEN
	463
	464	kinfo = OASIS_Rcv
	465	IF( llfisrt ) THEN
[6254]	466
	467	IF ( rootexchg ) THEN
	468
	469	! distribute data to processes
	470	!
	471	IF ( nproc == localRoot ) THEN
	472
	473	DO jn = 1, jpnij
	474	tbuf(nldit(jn):nleit(jn),nldjt(jn):nlejt(jn),jn)= &
	475	exfld(nimppt(jn)-1+nldit(jn):nimppt(jn)+nleit(jn)-1,njmppt(jn)-1+nldjt(jn):njmppt(jn)+nlejt(jn)-1)
	476	! NOTE: we are missing combining this with pmask (see else below)
	477	ENDDO
	478
	479	ENDIF
	480
	481	CALL mppscatter (tbuf,localRoot,pdata(:,:,jc))
	482	CALL mppsync
	483
	484	ELSE
	485
	486	pdata(nldi:nlei, nldj:nlej, jc) = exfld(:,:) * pmask(nldi:nlei,nldj:nlej,jm)
	487
	488	ENDIF
	489
[4990]	490	llfisrt = .FALSE.
	491	ELSE
	492	pdata(nldi:nlei,nldj:nlej,jc) = pdata(nldi:nlei,nldj:nlej,jc) + exfld(:,:) * pmask(nldi:nlei,nldj:nlej,jm)
	493	ENDIF
	494
	495	IF ( ln_ctl ) THEN
	496	WRITE(numout,) '***************'
	497	WRITE(numout,*) 'oasis_get: Incoming ', srcv(kid)%clname
	498	WRITE(numout,*) 'oasis_get: ivarid ' , srcv(kid)%nid(jc,jm)
	499	WRITE(numout,*) 'oasis_get: kstep', kstep
	500	WRITE(numout,*) 'oasis_get: info ', kinfo
	501	WRITE(numout,*) ' - Minimum value is ', MINVAL(pdata(:,:,jc))
	502	WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata(:,:,jc))
	503	WRITE(numout,*) ' - Sum value is ', SUM(pdata(:,:,jc))
	504	WRITE(numout,) '***************'
	505	ENDIF
	506
	507	ENDIF
	508
	509	ENDIF
[3294]	510
[4990]	511	ENDDO
[4806]	512
[4990]	513	!--- Fill the overlap areas and extra hallows (mpp)
	514	!--- check periodicity conditions (all cases)
	515	IF( .not. llfisrt ) CALL lbc_lnk( pdata(:,:,jc), srcv(kid)%clgrid, srcv(kid)%nsgn )
	516
[3294]	517	ENDDO
[2715]	518	!
[4990]	519	END SUBROUTINE cpl_rcv
[532]	520
	521
[5407]	522	INTEGER FUNCTION cpl_freq( cdfieldname )
[2528]	523	!!---------------------------------------------------------------------
[4990]	524	!! * ROUTINE cpl_freq *
[2528]	525	!!
	526	!! ** Purpose : - send back the coupling frequency for a particular field
	527	!!----------------------------------------------------------------------
[5407]	528	CHARACTER(len = *), INTENT(in) :: cdfieldname ! field name as set in namcouple file
[4990]	529	!!
[5407]	530	INTEGER :: id
[4990]	531	INTEGER :: info
	532	INTEGER, DIMENSION(1) :: itmp
[5407]	533	INTEGER :: ji,jm ! local loop index
	534	INTEGER :: mop
[2715]	535	!!----------------------------------------------------------------------
[5407]	536	cpl_freq = 0 ! defaut definition
	537	id = -1 ! defaut definition
[2715]	538	!
[5407]	539	DO ji = 1, nsnd
	540	IF (ssnd(ji)%laction ) THEN
	541	DO jm = 1, ncplmodel
	542	IF( ssnd(ji)%nid(1,jm) /= -1 ) THEN
	543	IF( TRIM(cdfieldname) == TRIM(ssnd(ji)%clname) ) THEN
	544	id = ssnd(ji)%nid(1,jm)
	545	mop = OASIS_Out
	546	ENDIF
	547	ENDIF
	548	ENDDO
	549	ENDIF
	550	ENDDO
	551	DO ji = 1, nrcv
	552	IF (srcv(ji)%laction ) THEN
	553	DO jm = 1, ncplmodel
	554	IF( srcv(ji)%nid(1,jm) /= -1 ) THEN
	555	IF( TRIM(cdfieldname) == TRIM(srcv(ji)%clname) ) THEN
	556	id = srcv(ji)%nid(1,jm)
	557	mop = OASIS_In
	558	ENDIF
	559	ENDIF
	560	ENDDO
	561	ENDIF
	562	ENDDO
	563	!
	564	IF( id /= -1 ) THEN
	565	#if defined key_oa3mct_v3
	566	CALL oasis_get_freqs(id, mop, 1, itmp, info)
[6254]	567	#endif
	568	#if defined key_oasis3
[5407]	569	CALL oasis_get_freqs(id, 1, itmp, info)
	570	#endif
	571	cpl_freq = itmp(1)
[6254]	572	#if defined key_oasis3mct
	573	cpl_freq = namflddti( id )
	574	#endif
[5407]	575	ENDIF
	576	!
[4990]	577	END FUNCTION cpl_freq
[2528]	578
	579
[4990]	580	SUBROUTINE cpl_finalize
[532]	581	!!---------------------------------------------------------------------
[4990]	582	!! * ROUTINE cpl_finalize *
[532]	583	!!
	584	!! ** Purpose : - Finalizes the coupling. If MPI_init has not been
[4990]	585	!! called explicitly before cpl_init it will also close
[532]	586	!! MPI communication.
	587	!!----------------------------------------------------------------------
[2715]	588	!
	589	DEALLOCATE( exfld )
[6254]	590	IF ( rootexchg ) DEALLOCATE ( tbuf )
[4990]	591	IF (nstop == 0) THEN
	592	CALL oasis_terminate( nerror )
	593	ELSE
	594	CALL oasis_abort( ncomp_id, "cpl_finalize", "NEMO ABORT STOP" )
	595	ENDIF
[2715]	596	!
[4990]	597	END SUBROUTINE cpl_finalize
[532]	598
[6254]	599	#if ! defined key_oasis3 && ! defined key_oasis3mct
[4990]	600
[1218]	601	!!----------------------------------------------------------------------
[4990]	602	!! No OASIS Library OASIS3 Dummy module...
[1218]	603	!!----------------------------------------------------------------------
[4990]	604
	605	SUBROUTINE oasis_init_comp(k1,cd1,k2)
	606	CHARACTER(*), INTENT(in ) :: cd1
	607	INTEGER , INTENT( out) :: k1,k2
	608	k1 = -1 ; k2 = -1
	609	WRITE(numout,*) 'oasis_init_comp: Error you sould not be there...', cd1
	610	END SUBROUTINE oasis_init_comp
	611
	612	SUBROUTINE oasis_abort(k1,cd1,cd2)
	613	INTEGER , INTENT(in ) :: k1
	614	CHARACTER(*), INTENT(in ) :: cd1,cd2
	615	WRITE(numout,*) 'oasis_abort: Error you sould not be there...', cd1, cd2
	616	END SUBROUTINE oasis_abort
	617
	618	SUBROUTINE oasis_get_localcomm(k1,k2)
	619	INTEGER , INTENT( out) :: k1,k2
	620	k1 = -1 ; k2 = -1
	621	WRITE(numout,*) 'oasis_get_localcomm: Error you sould not be there...'
	622	END SUBROUTINE oasis_get_localcomm
	623
	624	SUBROUTINE oasis_def_partition(k1,k2,k3)
	625	INTEGER , INTENT( out) :: k1,k3
	626	INTEGER , INTENT(in ) :: k2(5)
	627	k1 = k2(1) ; k3 = k2(5)
	628	WRITE(numout,*) 'oasis_def_partition: Error you sould not be there...'
	629	END SUBROUTINE oasis_def_partition
	630
	631	SUBROUTINE oasis_def_var(k1,cd1,k2,k3,k4,k5,k6,k7)
	632	CHARACTER(*), INTENT(in ) :: cd1
	633	INTEGER , INTENT(in ) :: k2,k3(2),k4,k5(2,2),k6
	634	INTEGER , INTENT( out) :: k1,k7
	635	k1 = -1 ; k7 = -1
	636	WRITE(numout,*) 'oasis_def_var: Error you sould not be there...', cd1
	637	END SUBROUTINE oasis_def_var
	638
	639	SUBROUTINE oasis_enddef(k1)
	640	INTEGER , INTENT( out) :: k1
	641	k1 = -1
	642	WRITE(numout,*) 'oasis_enddef: Error you sould not be there...'
	643	END SUBROUTINE oasis_enddef
	644
	645	SUBROUTINE oasis_put(k1,k2,p1,k3)
	646	REAL(wp), DIMENSION(:,:), INTENT(in ) :: p1
	647	INTEGER , INTENT(in ) :: k1,k2
	648	INTEGER , INTENT( out) :: k3
	649	k3 = -1
	650	WRITE(numout,*) 'oasis_put: Error you sould not be there...'
	651	END SUBROUTINE oasis_put
	652
	653	SUBROUTINE oasis_get(k1,k2,p1,k3)
	654	REAL(wp), DIMENSION(:,:), INTENT( out) :: p1
	655	INTEGER , INTENT(in ) :: k1,k2
	656	INTEGER , INTENT( out) :: k3
	657	p1(1,1) = -1. ; k3 = -1
	658	WRITE(numout,*) 'oasis_get: Error you sould not be there...'
	659	END SUBROUTINE oasis_get
	660
	661	SUBROUTINE oasis_get_freqs(k1,k2,k3,k4)
	662	INTEGER , INTENT(in ) :: k1,k2
	663	INTEGER, DIMENSION(1), INTENT( out) :: k3
	664	INTEGER , INTENT( out) :: k4
	665	k3(1) = k1 ; k4 = k2
	666	WRITE(numout,*) 'oasis_get_freqs: Error you sould not be there...'
	667	END SUBROUTINE oasis_get_freqs
	668
	669	SUBROUTINE oasis_terminate(k1)
	670	INTEGER , INTENT( out) :: k1
	671	k1 = -1
	672	WRITE(numout,*) 'oasis_terminate: Error you sould not be there...'
	673	END SUBROUTINE oasis_terminate
	674
[532]	675	#endif
	676
[2715]	677	!!=====================================================================
[532]	678	END MODULE cpl_oasis3

Note: See TracBrowser for help on using the repository browser.

Download in other formats: