Context Navigation

oasis.F90 @ 2220

Last change on this file since 2220 was 2056, checked in by Laurent Fairhead, 10 years ago
Merged trunk changes r1997:2055 into testing branch
Property copyright set to Name of program: LMDZ Creation date: 1984 Version: LMDZ5 License: CeCILL version 2 Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539 See the license file in the root directory Property svn:eol-style set to `native` Property svn:executable set to ``* Property svn:keywords set to `Author Date Id Revision`
File size: 18.2 KB

Rev	Line
[782]	1	!
	2	MODULE oasis
	3	!
	4	! This module contains subroutines for initialization, sending and receiving
	5	! towards the coupler OASIS3. It also contains some parameters for the coupling.
	6	!
	7	! This module should always be compiled. With the coupler OASIS3 available the cpp key
	8	! CPP_COUPLE should be set and the entier of this file will then be compiled.
	9	! In a forced mode CPP_COUPLE should not be defined and the compilation ends before
	10	! the CONTAINS, without compiling the subroutines.
	11	!
	12	USE dimphy
	13	USE mod_phys_lmdz_para
	14	USE write_field_phy
	15
	16	#ifdef CPP_COUPLE
[1999]	17	! Use of Oasis-MCT coupler
	18	#if defined CPP_OMCT
	19	USE mod_prism
	20	! Use of Oasis3 coupler
	21	#else
[782]	22	USE mod_prism_proto
	23	USE mod_prism_def_partition_proto
	24	USE mod_prism_get_proto
	25	USE mod_prism_put_proto
	26	#endif
[1999]	27	#endif
[782]	28
	29	IMPLICIT NONE
[1279]	30
	31	! Id for fields sent to ocean
	32	INTEGER, PARAMETER :: ids_tauxxu = 1
	33	INTEGER, PARAMETER :: ids_tauyyu = 2
	34	INTEGER, PARAMETER :: ids_tauzzu = 3
	35	INTEGER, PARAMETER :: ids_tauxxv = 4
	36	INTEGER, PARAMETER :: ids_tauyyv = 5
	37	INTEGER, PARAMETER :: ids_tauzzv = 6
	38	INTEGER, PARAMETER :: ids_windsp = 7
	39	INTEGER, PARAMETER :: ids_shfice = 8
	40	INTEGER, PARAMETER :: ids_shfoce = 9
	41	INTEGER, PARAMETER :: ids_shftot = 10
	42	INTEGER, PARAMETER :: ids_nsfice = 11
	43	INTEGER, PARAMETER :: ids_nsfoce = 12
	44	INTEGER, PARAMETER :: ids_nsftot = 13
	45	INTEGER, PARAMETER :: ids_dflxdt = 14
	46	INTEGER, PARAMETER :: ids_totrai = 15
	47	INTEGER, PARAMETER :: ids_totsno = 16
	48	INTEGER, PARAMETER :: ids_toteva = 17
	49	INTEGER, PARAMETER :: ids_icevap = 18
	50	INTEGER, PARAMETER :: ids_ocevap = 19
	51	INTEGER, PARAMETER :: ids_calvin = 20
	52	INTEGER, PARAMETER :: ids_liqrun = 21
	53	INTEGER, PARAMETER :: ids_runcoa = 22
	54	INTEGER, PARAMETER :: ids_rivflu = 23
	55	INTEGER, PARAMETER :: ids_atmco2 = 24
	56	INTEGER, PARAMETER :: ids_taumod = 25
	57	INTEGER, PARAMETER :: maxsend = 25 ! Maximum number of fields to send
	58
	59	! Id for fields received from ocean
	60	INTEGER, PARAMETER :: idr_sisutw = 1
	61	INTEGER, PARAMETER :: idr_icecov = 2
	62	INTEGER, PARAMETER :: idr_icealw = 3
	63	INTEGER, PARAMETER :: idr_icetem = 4
	64	INTEGER, PARAMETER :: idr_curenx = 5
	65	INTEGER, PARAMETER :: idr_cureny = 6
	66	INTEGER, PARAMETER :: idr_curenz = 7
	67	INTEGER, PARAMETER :: idr_oceco2 = 8
	68	INTEGER, PARAMETER :: maxrecv = 8 ! Maximum number of fields to receive
	69
[782]	70
[1279]	71	TYPE, PUBLIC :: FLD_CPL ! Type for coupling field information
	72	CHARACTER(len = 8) :: name ! Name of the coupling field
	73	LOGICAL :: action ! To be exchanged or not
	74	INTEGER :: nid ! Id of the field
	75	END TYPE FLD_CPL
[782]	76
[1279]	77	TYPE(FLD_CPL), DIMENSION(maxsend), SAVE, PUBLIC :: infosend ! Information for sending coupling fields
	78	TYPE(FLD_CPL), DIMENSION(maxrecv), SAVE, PUBLIC :: inforecv ! Information for receiving coupling fields
	79
	80	LOGICAL,SAVE :: cpl_current
	81	!$OMP THREADPRIVATE(cpl_current)
[782]	82
	83	#ifdef CPP_COUPLE
	84
	85	CONTAINS
	86
	87	SUBROUTINE inicma
	88	!************************************************************************************
	89	!**** INICMA - Initialize coupled mode communication for atmosphere
	90	! and exchange some initial information with Oasis
	91	!
	92	! Rewrite to take the PRISM/psmile library into account
	93	! LF 09/2003
	94	!
[1067]	95	USE IOIPSL
[996]	96	USE surface_data, ONLY : version_ocean
[1279]	97	USE carbon_cycle_mod, ONLY : carbon_cycle_cpl
[2056]	98	#ifdef CPP_XIOS
	99	USE wxios, ONLY : wxios_context_init
	100	#endif
[1279]	101
[2056]	102
[793]	103	INCLUDE "dimensions.h"
[1279]	104	INCLUDE "iniprint.h"
[782]	105
	106	! Local variables
	107	!************************************************************************************
	108	INTEGER :: comp_id
	109	INTEGER :: ierror, il_commlocal
	110	INTEGER :: il_part_id
	111	INTEGER, DIMENSION(3) :: ig_paral
	112	INTEGER, DIMENSION(2) :: il_var_nodims
	113	INTEGER, DIMENSION(4) :: il_var_actual_shape
	114	INTEGER :: il_var_type
	115	INTEGER :: jf
	116	CHARACTER (len = 6) :: clmodnam
	117	CHARACTER (len = 20) :: modname = 'inicma'
	118	CHARACTER (len = 80) :: abort_message
[1999]	119	LOGICAL, SAVE :: cpl_current_omp
[782]	120
	121	!* 1. Initializations
	122	! ---------------
	123	!************************************************************************************
[1279]	124	WRITE(lunout,*) ' '
	125	WRITE(lunout,*) ' '
	126	WRITE(lunout,*) ' ROUTINE INICMA'
	127	WRITE(lunout,) ' *************'
	128	WRITE(lunout,*) ' '
	129	WRITE(lunout,*) ' '
[782]	130
	131	!
	132	! Define the model name
	133	!
[2056]	134	clmodnam = 'LMDZ' ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
[1067]	135
[1279]	136
[782]	137	!************************************************************************************
[1067]	138	! Define if coupling ocean currents or not
	139	!************************************************************************************
	140	!$OMP MASTER
	141	cpl_current_omp = .FALSE.
	142	CALL getin('cpl_current', cpl_current_omp)
	143	!$OMP END MASTER
	144	!$OMP BARRIER
	145	cpl_current = cpl_current_omp
[1279]	146	WRITE(lunout,*) 'Couple ocean currents, cpl_current = ',cpl_current
[1067]	147
	148	!************************************************************************************
[1279]	149	! Define coupling variables
	150	!************************************************************************************
	151
	152	! Atmospheric variables to send
	153
	154	!$OMP MASTER
	155	infosend(:)%action = .FALSE.
	156
	157	infosend(ids_tauxxu)%action = .TRUE. ; infosend(ids_tauxxu)%name = 'COTAUXXU'
	158	infosend(ids_tauyyu)%action = .TRUE. ; infosend(ids_tauyyu)%name = 'COTAUYYU'
	159	infosend(ids_tauzzu)%action = .TRUE. ; infosend(ids_tauzzu)%name = 'COTAUZZU'
	160	infosend(ids_tauxxv)%action = .TRUE. ; infosend(ids_tauxxv)%name = 'COTAUXXV'
	161	infosend(ids_tauyyv)%action = .TRUE. ; infosend(ids_tauyyv)%name = 'COTAUYYV'
	162	infosend(ids_tauzzv)%action = .TRUE. ; infosend(ids_tauzzv)%name = 'COTAUZZV'
	163	infosend(ids_windsp)%action = .TRUE. ; infosend(ids_windsp)%name = 'COWINDSP'
	164	infosend(ids_shfice)%action = .TRUE. ; infosend(ids_shfice)%name = 'COSHFICE'
	165	infosend(ids_nsfice)%action = .TRUE. ; infosend(ids_nsfice)%name = 'CONSFICE'
	166	infosend(ids_dflxdt)%action = .TRUE. ; infosend(ids_dflxdt)%name = 'CODFLXDT'
	167	infosend(ids_calvin)%action = .TRUE. ; infosend(ids_calvin)%name = 'COCALVIN'
	168
	169	IF (version_ocean=='nemo') THEN
	170	infosend(ids_shftot)%action = .TRUE. ; infosend(ids_shftot)%name = 'COQSRMIX'
	171	infosend(ids_nsftot)%action = .TRUE. ; infosend(ids_nsftot)%name = 'COQNSMIX'
	172	infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOTRAI'
	173	infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOTSNO'
	174	infosend(ids_toteva)%action = .TRUE. ; infosend(ids_toteva)%name = 'COTOTEVA'
	175	infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COICEVAP'
	176	infosend(ids_liqrun)%action = .TRUE. ; infosend(ids_liqrun)%name = 'COLIQRUN'
	177	infosend(ids_taumod)%action = .TRUE. ; infosend(ids_taumod)%name = 'COTAUMOD'
	178	IF (carbon_cycle_cpl) THEN
	179	infosend(ids_atmco2)%action = .TRUE. ; infosend(ids_atmco2)%name = 'COATMCO2'
	180	ENDIF
	181
	182	ELSE IF (version_ocean=='opa8') THEN
	183	infosend(ids_shfoce)%action = .TRUE. ; infosend(ids_shfoce)%name = 'COSHFOCE'
	184	infosend(ids_nsfoce)%action = .TRUE. ; infosend(ids_nsfoce)%name = 'CONSFOCE'
	185	infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COTFSICE'
	186	infosend(ids_ocevap)%action = .TRUE. ; infosend(ids_ocevap)%name = 'COTFSOCE'
	187	infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOLPSU'
	188	infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOSPSU'
	189	infosend(ids_runcoa)%action = .TRUE. ; infosend(ids_runcoa)%name = 'CORUNCOA'
	190	infosend(ids_rivflu)%action = .TRUE. ; infosend(ids_rivflu)%name = 'CORIVFLU'
	191	ENDIF
	192
	193	! Oceanic variables to receive
	194
	195	inforecv(:)%action = .FALSE.
	196
	197	inforecv(idr_sisutw)%action = .TRUE. ; inforecv(idr_sisutw)%name = 'SISUTESW'
	198	inforecv(idr_icecov)%action = .TRUE. ; inforecv(idr_icecov)%name = 'SIICECOV'
	199	inforecv(idr_icealw)%action = .TRUE. ; inforecv(idr_icealw)%name = 'SIICEALW'
	200	inforecv(idr_icetem)%action = .TRUE. ; inforecv(idr_icetem)%name = 'SIICTEMW'
	201
	202	IF (cpl_current ) THEN
	203	inforecv(idr_curenx)%action = .TRUE. ; inforecv(idr_curenx)%name = 'CURRENTX'
	204	inforecv(idr_cureny)%action = .TRUE. ; inforecv(idr_cureny)%name = 'CURRENTY'
	205	inforecv(idr_curenz)%action = .TRUE. ; inforecv(idr_curenz)%name = 'CURRENTZ'
	206	ENDIF
	207
	208	IF (carbon_cycle_cpl ) THEN
	209	inforecv(idr_oceco2)%action = .TRUE. ; inforecv(idr_oceco2)%name = 'SICO2FLX'
	210	ENDIF
	211
	212	!************************************************************************************
[782]	213	! Here we go: psmile initialisation
	214	!************************************************************************************
	215	IF (is_sequential) THEN
	216	CALL prism_init_comp_proto (comp_id, clmodnam, ierror)
	217
	218	IF (ierror .NE. PRISM_Ok) THEN
	219	abort_message=' Probleme init dans prism_init_comp '
	220	CALL abort_gcm(modname,abort_message,1)
	221	ELSE
[1279]	222	WRITE(lunout,*) 'inicma : init psmile ok '
[782]	223	ENDIF
	224	ENDIF
	225
	226	CALL prism_get_localcomm_proto (il_commlocal, ierror)
	227	!************************************************************************************
	228	! Domain decomposition
	229	!************************************************************************************
	230	ig_paral(1) = 1 ! apple partition for //
	231	ig_paral(2) = (jj_begin-1)*iim+ii_begin-1 ! offset
	232	ig_paral(3) = (jj_endiim+ii_end) - (jj_beginiim+ii_begin) + 1
	233
	234	IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+iim-1
[1279]	235	WRITE(lunout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3)
[782]	236
	237	ierror=PRISM_Ok
	238	CALL prism_def_partition_proto (il_part_id, ig_paral, ierror)
	239
	240	IF (ierror .NE. PRISM_Ok) THEN
	241	abort_message=' Probleme dans prism_def_partition '
	242	CALL abort_gcm(modname,abort_message,1)
	243	ELSE
[1279]	244	WRITE(lunout,*) 'inicma : decomposition domaine psmile ok '
[782]	245	ENDIF
	246
	247	il_var_nodims(1) = 2
	248	il_var_nodims(2) = 1
	249
	250	il_var_actual_shape(1) = 1
	251	il_var_actual_shape(2) = iim
	252	il_var_actual_shape(3) = 1
	253	il_var_actual_shape(4) = jjm+1
	254
	255	il_var_type = PRISM_Real
	256
	257	!************************************************************************************
[1279]	258	! Oceanic Fields to receive
	259	! Loop over all possible variables
[782]	260	!************************************************************************************
[1279]	261	DO jf=1, maxrecv
	262	IF (inforecv(jf)%action) THEN
	263	CALL prism_def_var_proto(inforecv(jf)%nid, inforecv(jf)%name, il_part_id, &
	264	il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
	265	ierror)
	266	IF (ierror .NE. PRISM_Ok) THEN
	267	WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',&
	268	inforecv(jf)%name
	269	abort_message=' Problem in call to prism_def_var_proto for fields to receive'
	270	CALL abort_gcm(modname,abort_message,1)
	271	ENDIF
[782]	272	ENDIF
	273	END DO
[1279]	274
[782]	275	!************************************************************************************
[1279]	276	! Atmospheric Fields to send
	277	! Loop over all possible variables
[782]	278	!************************************************************************************
[1279]	279	DO jf=1,maxsend
	280	IF (infosend(jf)%action) THEN
	281	CALL prism_def_var_proto(infosend(jf)%nid, infosend(jf)%name, il_part_id, &
	282	il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, &
	283	ierror)
	284	IF (ierror .NE. PRISM_Ok) THEN
	285	WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',&
	286	infosend(jf)%name
	287	abort_message=' Problem in call to prism_def_var_proto for fields to send'
	288	CALL abort_gcm(modname,abort_message,1)
	289	ENDIF
[782]	290	ENDIF
	291	END DO
[1279]	292
[782]	293	!************************************************************************************
	294	! End definition
	295	!************************************************************************************
	296	CALL prism_enddef_proto(ierror)
	297	IF (ierror .NE. PRISM_Ok) THEN
[1279]	298	abort_message=' Problem in call to prism_endef_proto'
[782]	299	CALL abort_gcm(modname,abort_message,1)
	300	ELSE
[1279]	301	WRITE(lunout,*) 'inicma : endef psmile ok '
[782]	302	ENDIF
[1279]	303
[2056]	304	#ifdef CPP_XIOS
	305	CALL wxios_context_init()
	306	#endif
	307
[1279]	308	!$OMP END MASTER
[782]	309
	310	END SUBROUTINE inicma
	311
	312	!
	313	!************************************************************************************
	314	!
	315
	316	SUBROUTINE fromcpl(ktime, tab_get)
	317	! ======================================================================
	318	! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST
	319	! and Sea-Ice provided by the coupler. Adaptation to psmile library
	320	!======================================================================
	321	!
[793]	322	INCLUDE "dimensions.h"
[1279]	323	INCLUDE "iniprint.h"
[782]	324	! Input arguments
	325	!************************************************************************************
	326	INTEGER, INTENT(IN) :: ktime
	327
	328	! Output arguments
	329	!************************************************************************************
[1279]	330	REAL, DIMENSION(iim, jj_nb,maxrecv), INTENT(OUT) :: tab_get
[782]	331
	332	! Local variables
	333	!************************************************************************************
	334	INTEGER :: ierror, i
	335	INTEGER :: istart,iend
	336	CHARACTER (len = 20) :: modname = 'fromcpl'
	337	CHARACTER (len = 80) :: abort_message
	338	REAL, DIMENSION(iim*jj_nb) :: field
	339
	340	!************************************************************************************
[1279]	341	WRITE (lunout,*) ' '
	342	WRITE (lunout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime
	343	WRITE (lunout,*) ' '
[782]	344
	345	istart=ii_begin
	346	IF (is_south_pole) THEN
	347	iend=(jj_end-jj_begin)*iim+iim
	348	ELSE
	349	iend=(jj_end-jj_begin)*iim+ii_end
	350	ENDIF
	351
[1279]	352	DO i = 1, maxrecv
[1999]	353	IF (inforecv(i)%action .AND. inforecv(i)%nid .NE. -1) THEN
[1279]	354	field(:) = -99999.
	355	CALL prism_get_proto(inforecv(i)%nid, ktime, field(istart:iend), ierror)
	356	tab_get(:,:,i) = RESHAPE(field(:),(/iim,jj_nb/))
[782]	357
[1279]	358	IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Recvd .AND. &
	359	ierror.NE.PRISM_FromRest &
	360	.AND. ierror.NE.PRISM_Input .AND. ierror.NE.PRISM_RecvOut &
	361	.AND. ierror.NE.PRISM_FromRestOut) THEN
	362	WRITE (lunout,*) 'Error with receiving filed : ', inforecv(i)%name, ktime
	363	abort_message=' Problem in prism_get_proto '
	364	CALL abort_gcm(modname,abort_message,1)
	365	ENDIF
	366	ENDIF
[782]	367	END DO
	368
	369
	370	END SUBROUTINE fromcpl
	371
	372	!
	373	!************************************************************************************
	374	!
	375
	376	SUBROUTINE intocpl(ktime, last, tab_put)
	377	! ======================================================================
	378	! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the
	379	! atmospheric coupling fields to the coupler with the psmile library.
	380	! IF last time step, writes output fields to binary files.
	381	! ======================================================================
	382	!
	383	!
[793]	384	INCLUDE "dimensions.h"
[1279]	385	INCLUDE "iniprint.h"
[782]	386	! Input arguments
	387	!************************************************************************************
[1279]	388	INTEGER, INTENT(IN) :: ktime
	389	LOGICAL, INTENT(IN) :: last
	390	REAL, DIMENSION(iim, jj_nb, maxsend), INTENT(IN) :: tab_put
[782]	391
	392	! Local variables
	393	!************************************************************************************
[987]	394	LOGICAL :: checkout
	395	INTEGER :: istart,iend
	396	INTEGER :: wstart,wend
	397	INTEGER :: ierror, i
	398	REAL, DIMENSION(iim*jj_nb) :: field
	399	CHARACTER (len = 20),PARAMETER :: modname = 'intocpl'
	400	CHARACTER (len = 80) :: abort_message
[782]	401
	402	!************************************************************************************
[987]	403	checkout=.FALSE.
[782]	404
[1279]	405	WRITE(lunout,*) ' '
	406	WRITE(lunout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime
	407	WRITE(lunout,*) 'last = ', last
	408	WRITE(lunout,*)
[782]	409
	410
	411	istart=ii_begin
	412	IF (is_south_pole) THEN
	413	iend=(jj_end-jj_begin)*iim+iim
	414	ELSE
	415	iend=(jj_end-jj_begin)*iim+ii_end
	416	ENDIF
	417
	418	IF (checkout) THEN
	419	wstart=istart
	420	wend=iend
	421	IF (is_north_pole) wstart=istart+iim-1
	422	IF (is_south_pole) wend=iend-iim+1
	423
[1279]	424	DO i = 1, maxsend
	425	IF (infosend(i)%action) THEN
	426	field = RESHAPE(tab_put(:,:,i),(/iim*jj_nb/))
	427	CALL writefield_phy(infosend(i)%name,field(wstart:wend),1)
	428	END IF
	429	END DO
	430	END IF
	431
[782]	432	!************************************************************************************
	433	! PRISM_PUT
	434	!************************************************************************************
	435
[1279]	436	DO i = 1, maxsend
[1999]	437	IF (infosend(i)%action .AND. infosend(i)%nid .NE. -1 ) THEN
[1279]	438	field = RESHAPE(tab_put(:,:,i),(/iim*jj_nb/))
	439	CALL prism_put_proto(infosend(i)%nid, ktime, field(istart:iend), ierror)
	440
	441	IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Sent .AND. ierror.NE.PRISM_ToRest &
	442	.AND. ierror.NE.PRISM_LocTrans .AND. ierror.NE.PRISM_Output .AND. &
	443	ierror.NE.PRISM_SentOut .AND. ierror.NE.PRISM_ToRestOut) THEN
	444	WRITE (lunout,*) 'Error with sending field :', infosend(i)%name, ktime
	445	abort_message=' Problem in prism_put_proto '
	446	CALL abort_gcm(modname,abort_message,1)
	447	ENDIF
	448	ENDIF
[782]	449	END DO
	450
	451	!************************************************************************************
	452	! Finalize PSMILE for the case is_sequential, if parallel finalization is done
	453	! from Finalize_parallel in dyn3dpar/parallel.F90
	454	!************************************************************************************
	455
	456	IF (last) THEN
	457	IF (is_sequential) THEN
	458	CALL prism_terminate_proto(ierror)
	459	IF (ierror .NE. PRISM_Ok) THEN
[1279]	460	abort_message=' Problem in prism_terminate_proto '
[782]	461	CALL abort_gcm(modname,abort_message,1)
	462	ENDIF
	463	ENDIF
	464	ENDIF
	465
	466
	467	END SUBROUTINE intocpl
	468
	469	#endif
	470
	471	END MODULE oasis

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

Download in other formats:

Original Format