Context Navigation

oasis.F90 @ 5654

Last change on this file since 5654 was 5654, checked in by acozic, 8 weeks ago
Add possibility to send N2O from atm chemistry (with Inca model - but definition for oasis is done in LMDZ) to NEMO
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:keywords set to `Author Date Id Revision`
File size: 22.8 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
[1965]	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
[1965]	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
[2872]	57	INTEGER, PARAMETER :: ids_qraioc = 26
	58	INTEGER, PARAMETER :: ids_qsnooc = 27
	59	INTEGER, PARAMETER :: ids_qraiic = 28
	60	INTEGER, PARAMETER :: ids_qsnoic = 29
[4370]	61	INTEGER, PARAMETER :: ids_delta_sst = 30, ids_delta_sal = 31, ids_dter = 32, &
	62	ids_dser = 33, ids_dt_ds = 34
[5654]	63	INTEGER, PARAMETER :: ids_atmn2o = 35
[1279]	64
[5654]	65	INTEGER, PARAMETER :: maxsend = 35 ! Maximum number of fields to send
	66	INTEGER, PARAMETER :: maxsend_phys = 34 ! Maximum number of fields to send in LMDZ phys - the last one will be send by Inca
	67
[1279]	68	! Id for fields received from ocean
[3815]	69
[1279]	70	INTEGER, PARAMETER :: idr_sisutw = 1
	71	INTEGER, PARAMETER :: idr_icecov = 2
	72	INTEGER, PARAMETER :: idr_icealw = 3
	73	INTEGER, PARAMETER :: idr_icetem = 4
	74	INTEGER, PARAMETER :: idr_curenx = 5
	75	INTEGER, PARAMETER :: idr_cureny = 6
	76	INTEGER, PARAMETER :: idr_curenz = 7
	77	INTEGER, PARAMETER :: idr_oceco2 = 8
[4640]	78	! bulk salinity of the surface layer of the ocean, in ppt
[3815]	79	INTEGER, PARAMETER :: idr_sss = 9
[4640]	80	INTEGER, PARAMETER :: idr_ocedms = 10
[4754]	81	INTEGER, PARAMETER :: idr_ocen2o = 11
[3815]	82
[4754]	83	INTEGER, PARAMETER :: maxrecv = 11 ! Maximum number of fields to receive
[4640]	84	INTEGER, PARAMETER :: maxrecv_phys = 9 ! Maximum number of fields to receive in physiq (without fields received in INCA model )
	85	! will be changed in next version - INCA fields will be received in LMDZ (like for ORCHIDEE fields)
	86	! and then send by routine in INCA model
[1279]	87
[782]	88
[1279]	89	TYPE, PUBLIC :: FLD_CPL ! Type for coupling field information
	90	CHARACTER(len = 8) :: name ! Name of the coupling field
	91	LOGICAL :: action ! To be exchanged or not
	92	INTEGER :: nid ! Id of the field
	93	END TYPE FLD_CPL
[782]	94
[1279]	95	TYPE(FLD_CPL), DIMENSION(maxsend), SAVE, PUBLIC :: infosend ! Information for sending coupling fields
[2916]	96	!$OMP THREADPRIVATE(infosend)
[1279]	97	TYPE(FLD_CPL), DIMENSION(maxrecv), SAVE, PUBLIC :: inforecv ! Information for receiving coupling fields
[2916]	98	!$OMP THREADPRIVATE(inforecv)
[1279]	99
	100	LOGICAL,SAVE :: cpl_current
	101	!$OMP THREADPRIVATE(cpl_current)
[782]	102
	103	#ifdef CPP_COUPLE
	104
	105	CONTAINS
	106
	107	SUBROUTINE inicma
	108	!************************************************************************************
	109	!**** INICMA - Initialize coupled mode communication for atmosphere
	110	! and exchange some initial information with Oasis
	111	!
	112	! Rewrite to take the PRISM/psmile library into account
	113	! LF 09/2003
	114	!
[1067]	115	USE IOIPSL
[996]	116	USE surface_data, ONLY : version_ocean
[1279]	117	USE carbon_cycle_mod, ONLY : carbon_cycle_cpl
[5310]	118	use wxios_mod, ONLY : wxios_context_init
[4754]	119	USE chemistry_cycle_mod, ONLY : dms_cycle_cpl, n2o_cycle_cpl
[4619]	120	USE lmdz_xios
[2311]	121	USE print_control_mod, ONLY: lunout
[3465]	122	USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, grid_type, unstructured, regular_lonlat
	123	USE geometry_mod, ONLY: ind_cell_glo
	124	USE mod_phys_lmdz_mpi_data, ONLY: klon_mpi_para_nb
[3815]	125	use config_ocean_skin_m, only: activate_ocean_skin
[5251]	126	USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_INCA
[1279]	127
[782]	128	! Local variables
	129	!************************************************************************************
	130	INTEGER :: comp_id
	131	INTEGER :: ierror, il_commlocal
	132	INTEGER :: il_part_id
[3465]	133	INTEGER, ALLOCATABLE :: ig_paral(:)
[782]	134	INTEGER, DIMENSION(2) :: il_var_nodims
	135	INTEGER, DIMENSION(4) :: il_var_actual_shape
	136	INTEGER :: il_var_type
	137	INTEGER :: jf
	138	CHARACTER (len = 6) :: clmodnam
	139	CHARACTER (len = 20) :: modname = 'inicma'
	140	CHARACTER (len = 80) :: abort_message
[5582]	141	!! WARNING: cpl_current_omp should NOT be put in a THREADPRIVATE statement, it is shared between tasks
[1997]	142	LOGICAL, SAVE :: cpl_current_omp
[4596]	143	INTEGER, DIMENSION(klon_mpi) :: ind_cell_glo_mpi
[782]	144
[5483]	145
[782]	146	!* 1. Initializations
	147	! ---------------
	148	!************************************************************************************
[1279]	149	WRITE(lunout,*) ' '
	150	WRITE(lunout,*) ' '
	151	WRITE(lunout,*) ' ROUTINE INICMA'
	152	WRITE(lunout,) ' *************'
	153	WRITE(lunout,*) ' '
	154	WRITE(lunout,*) ' '
[782]	155
	156	!
	157	! Define the model name
	158	!
[3465]	159	IF (grid_type==unstructured) THEN
	160	clmodnam = 'icosa' ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
	161	ELSE IF (grid_type==regular_lonlat) THEN
	162	clmodnam = 'LMDZ' ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
	163	ELSE
	164	abort_message='Pb : type of grid unknown'
	165	CALL abort_physic(modname,abort_message,1)
	166	ENDIF
[1067]	167
[1279]	168
[782]	169	!************************************************************************************
[1067]	170	! Define if coupling ocean currents or not
	171	!************************************************************************************
	172	!$OMP MASTER
	173	cpl_current_omp = .FALSE.
	174	CALL getin('cpl_current', cpl_current_omp)
	175	!$OMP END MASTER
	176	!$OMP BARRIER
	177	cpl_current = cpl_current_omp
[1279]	178	WRITE(lunout,*) 'Couple ocean currents, cpl_current = ',cpl_current
[1067]	179
	180	!************************************************************************************
[4596]	181	! Gather global index to be used for oasis decomposition
	182	!************************************************************************************
	183	CALL gather_omp(ind_cell_glo,ind_cell_glo_mpi)
	184
	185	!************************************************************************************
[1279]	186	! Define coupling variables
	187	!************************************************************************************
	188
	189	! Atmospheric variables to send
	190
	191	!$OMP MASTER
	192	infosend(:)%action = .FALSE.
	193
	194	infosend(ids_tauxxu)%action = .TRUE. ; infosend(ids_tauxxu)%name = 'COTAUXXU'
	195	infosend(ids_tauyyu)%action = .TRUE. ; infosend(ids_tauyyu)%name = 'COTAUYYU'
	196	infosend(ids_tauzzu)%action = .TRUE. ; infosend(ids_tauzzu)%name = 'COTAUZZU'
	197	infosend(ids_tauxxv)%action = .TRUE. ; infosend(ids_tauxxv)%name = 'COTAUXXV'
	198	infosend(ids_tauyyv)%action = .TRUE. ; infosend(ids_tauyyv)%name = 'COTAUYYV'
	199	infosend(ids_tauzzv)%action = .TRUE. ; infosend(ids_tauzzv)%name = 'COTAUZZV'
	200	infosend(ids_windsp)%action = .TRUE. ; infosend(ids_windsp)%name = 'COWINDSP'
	201	infosend(ids_shfice)%action = .TRUE. ; infosend(ids_shfice)%name = 'COSHFICE'
	202	infosend(ids_nsfice)%action = .TRUE. ; infosend(ids_nsfice)%name = 'CONSFICE'
	203	infosend(ids_dflxdt)%action = .TRUE. ; infosend(ids_dflxdt)%name = 'CODFLXDT'
	204	infosend(ids_calvin)%action = .TRUE. ; infosend(ids_calvin)%name = 'COCALVIN'
	205
[3815]	206	if (activate_ocean_skin == 2) then
	207	infosend(ids_delta_sst)%action = .TRUE.
	208	infosend(ids_delta_sst)%name = 'CODELSST'
	209	infosend(ids_delta_sal)%action = .TRUE.
	210	infosend(ids_delta_sal)%name = 'CODELSSS'
[4370]	211	infosend(ids_dter)%action = .TRUE.
	212	infosend(ids_dter)%name = 'CODELTER'
	213	infosend(ids_dser)%action = .TRUE.
	214	infosend(ids_dser)%name = 'CODELSER'
	215	infosend(ids_dt_ds)%action = .TRUE.
	216	infosend(ids_dt_ds)%name = 'CODTDS'
[3815]	217	end if
	218
[1279]	219	IF (version_ocean=='nemo') THEN
	220	infosend(ids_shftot)%action = .TRUE. ; infosend(ids_shftot)%name = 'COQSRMIX'
	221	infosend(ids_nsftot)%action = .TRUE. ; infosend(ids_nsftot)%name = 'COQNSMIX'
	222	infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOTRAI'
	223	infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOTSNO'
	224	infosend(ids_toteva)%action = .TRUE. ; infosend(ids_toteva)%name = 'COTOTEVA'
	225	infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COICEVAP'
	226	infosend(ids_liqrun)%action = .TRUE. ; infosend(ids_liqrun)%name = 'COLIQRUN'
	227	infosend(ids_taumod)%action = .TRUE. ; infosend(ids_taumod)%name = 'COTAUMOD'
	228	IF (carbon_cycle_cpl) THEN
	229	infosend(ids_atmco2)%action = .TRUE. ; infosend(ids_atmco2)%name = 'COATMCO2'
	230	ENDIF
[5654]	231	IF (n2o_cycle_cpl) THEN
	232	infosend(ids_atmn2o)%action = .TRUE. ; infosend(ids_atmn2o)%name = 'COATMN2O'
	233	ENDIF
[2872]	234	infosend(ids_qraioc)%action = .TRUE. ; infosend(ids_qraioc)%name = 'COQRAIOC'
	235	infosend(ids_qsnooc)%action = .TRUE. ; infosend(ids_qsnooc)%name = 'COQSNOOC'
	236	infosend(ids_qraiic)%action = .TRUE. ; infosend(ids_qraiic)%name = 'COQRAIIC'
	237	infosend(ids_qsnoic)%action = .TRUE. ; infosend(ids_qsnoic)%name = 'COQSNOIC'
[1279]	238
	239	ELSE IF (version_ocean=='opa8') THEN
	240	infosend(ids_shfoce)%action = .TRUE. ; infosend(ids_shfoce)%name = 'COSHFOCE'
	241	infosend(ids_nsfoce)%action = .TRUE. ; infosend(ids_nsfoce)%name = 'CONSFOCE'
	242	infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COTFSICE'
	243	infosend(ids_ocevap)%action = .TRUE. ; infosend(ids_ocevap)%name = 'COTFSOCE'
	244	infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOLPSU'
	245	infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOSPSU'
	246	infosend(ids_runcoa)%action = .TRUE. ; infosend(ids_runcoa)%name = 'CORUNCOA'
	247	infosend(ids_rivflu)%action = .TRUE. ; infosend(ids_rivflu)%name = 'CORIVFLU'
	248	ENDIF
	249
	250	! Oceanic variables to receive
	251
	252	inforecv(:)%action = .FALSE.
	253
	254	inforecv(idr_sisutw)%action = .TRUE. ; inforecv(idr_sisutw)%name = 'SISUTESW'
	255	inforecv(idr_icecov)%action = .TRUE. ; inforecv(idr_icecov)%name = 'SIICECOV'
	256	inforecv(idr_icealw)%action = .TRUE. ; inforecv(idr_icealw)%name = 'SIICEALW'
	257	inforecv(idr_icetem)%action = .TRUE. ; inforecv(idr_icetem)%name = 'SIICTEMW'
[3815]	258
	259	if (activate_ocean_skin >= 1) then
	260	inforecv(idr_sss)%action = .TRUE.
	261	inforecv(idr_sss)%name = 'SISUSALW'
	262	end if
[1279]	263
	264	IF (cpl_current ) THEN
	265	inforecv(idr_curenx)%action = .TRUE. ; inforecv(idr_curenx)%name = 'CURRENTX'
	266	inforecv(idr_cureny)%action = .TRUE. ; inforecv(idr_cureny)%name = 'CURRENTY'
	267	inforecv(idr_curenz)%action = .TRUE. ; inforecv(idr_curenz)%name = 'CURRENTZ'
	268	ENDIF
	269
	270	IF (carbon_cycle_cpl ) THEN
	271	inforecv(idr_oceco2)%action = .TRUE. ; inforecv(idr_oceco2)%name = 'SICO2FLX'
	272	ENDIF
[4640]	273	IF (dms_cycle_cpl) THEN
	274	inforecv(idr_ocedms)%action = .TRUE. ; inforecv(idr_ocedms)%name = 'SIDMSFLX'
	275	ENDIF
[4754]	276	IF (n2o_cycle_cpl) THEN
	277	inforecv(idr_ocen2o)%action = .TRUE. ; inforecv(idr_ocen2o)%name = 'SIN2OFLX'
	278	ENDIF
[4640]	279
[1279]	280
	281	!************************************************************************************
[782]	282	! Here we go: psmile initialisation
	283	!************************************************************************************
	284	IF (is_sequential) THEN
	285	CALL prism_init_comp_proto (comp_id, clmodnam, ierror)
	286
	287	IF (ierror .NE. PRISM_Ok) THEN
	288	abort_message=' Probleme init dans prism_init_comp '
[2311]	289	CALL abort_physic(modname,abort_message,1)
[782]	290	ELSE
[1279]	291	WRITE(lunout,*) 'inicma : init psmile ok '
[782]	292	ENDIF
	293	ENDIF
	294
	295	CALL prism_get_localcomm_proto (il_commlocal, ierror)
	296	!************************************************************************************
	297	! Domain decomposition
	298	!************************************************************************************
[3465]	299	IF (grid_type==unstructured) THEN
[782]	300
[3465]	301	ALLOCATE( ig_paral(klon_mpi_para_nb(mpi_rank) + 2) )
	302
	303	ig_paral(1) = 4 ! points partition for //
	304	ig_paral(2) = klon_mpi_para_nb(mpi_rank) ! nb of local cells
	305
	306	DO jf=1, klon_mpi_para_nb(mpi_rank)
[4596]	307	ig_paral(2+jf) = ind_cell_glo_mpi(jf)
[3465]	308	ENDDO
	309
	310	ELSE IF (grid_type==regular_lonlat) THEN
	311
	312	ALLOCATE( ig_paral(3) )
	313
	314	ig_paral(1) = 1 ! apple partition for //
	315	ig_paral(2) = (jj_begin-1)*nbp_lon+ii_begin-1 ! offset
	316	ig_paral(3) = (jj_endnbp_lon+ii_end) - (jj_beginnbp_lon+ii_begin) + 1
	317
	318	IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+nbp_lon-1
	319	ELSE
	320	abort_message='Pb : type of grid unknown'
	321	CALL abort_physic(modname,abort_message,1)
	322	ENDIF
	323
	324
[1279]	325	WRITE(lunout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3)
[782]	326
	327	ierror=PRISM_Ok
	328	CALL prism_def_partition_proto (il_part_id, ig_paral, ierror)
	329
	330	IF (ierror .NE. PRISM_Ok) THEN
	331	abort_message=' Probleme dans prism_def_partition '
[2311]	332	CALL abort_physic(modname,abort_message,1)
[782]	333	ELSE
[1279]	334	WRITE(lunout,*) 'inicma : decomposition domaine psmile ok '
[782]	335	ENDIF
	336
[3465]	337	il_var_nodims(1) = 2 ! rank of field array (1d or 2d)
	338	il_var_nodims(2) = 1 ! always 1 in current oasis version" doc oasis3mct p18
[782]	339
[3465]	340	il_var_actual_shape(1) = 1 ! min of 1st dimension (always 1)
	341	il_var_actual_shape(2) = nbp_lon ! max of 1st dimension
	342	il_var_actual_shape(3) = 1 ! min of 2nd dimension (always 1)
	343	il_var_actual_shape(4) = nbp_lat ! max of 2nd dimension
[782]	344
	345	il_var_type = PRISM_Real
	346
	347	!************************************************************************************
[1279]	348	! Oceanic Fields to receive
	349	! Loop over all possible variables
[782]	350	!************************************************************************************
[1279]	351	DO jf=1, maxrecv
	352	IF (inforecv(jf)%action) THEN
	353	CALL prism_def_var_proto(inforecv(jf)%nid, inforecv(jf)%name, il_part_id, &
	354	il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
	355	ierror)
	356	IF (ierror .NE. PRISM_Ok) THEN
	357	WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',&
	358	inforecv(jf)%name
	359	abort_message=' Problem in call to prism_def_var_proto for fields to receive'
[2311]	360	CALL abort_physic(modname,abort_message,1)
[1279]	361	ENDIF
[782]	362	ENDIF
	363	END DO
[4247]	364
	365
[782]	366	!************************************************************************************
[1279]	367	! Atmospheric Fields to send
	368	! Loop over all possible variables
[782]	369	!************************************************************************************
[1279]	370	DO jf=1,maxsend
	371	IF (infosend(jf)%action) THEN
	372	CALL prism_def_var_proto(infosend(jf)%nid, infosend(jf)%name, il_part_id, &
	373	il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, &
	374	ierror)
	375	IF (ierror .NE. PRISM_Ok) THEN
	376	WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',&
	377	infosend(jf)%name
	378	abort_message=' Problem in call to prism_def_var_proto for fields to send'
[2311]	379	CALL abort_physic(modname,abort_message,1)
[1279]	380	ENDIF
[782]	381	ENDIF
	382	END DO
[1279]	383
[782]	384	!************************************************************************************
	385	! End definition
	386	!************************************************************************************
[4619]	387
	388	IF (using_xios) CALL xios_oasis_enddef()
	389
[782]	390	CALL prism_enddef_proto(ierror)
	391	IF (ierror .NE. PRISM_Ok) THEN
[1279]	392	abort_message=' Problem in call to prism_endef_proto'
[2311]	393	CALL abort_physic(modname,abort_message,1)
[782]	394	ELSE
[1279]	395	WRITE(lunout,*) 'inicma : endef psmile ok '
[782]	396	ENDIF
[1279]	397
[5654]	398
	399	IF (CPPKEY_INCA) THEN
	400	IF (dms_cycle_cpl .OR. n2o_cycle_cpl) THEN
	401	CALL init_inca_oasis(inforecv(idr_ocedms:idr_ocen2o),infosend(ids_atmn2o:ids_atmn2o))
	402	ENDIF
	403	END IF
	404
[4642]	405	!$OMP END MASTER
[782]	406
	407	END SUBROUTINE inicma
	408
	409	!
	410	!************************************************************************************
	411	!
	412
	413	SUBROUTINE fromcpl(ktime, tab_get)
	414	! ======================================================================
	415	! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST
	416	! and Sea-Ice provided by the coupler. Adaptation to psmile library
	417	!======================================================================
	418	!
[2311]	419	USE print_control_mod, ONLY: lunout
[2371]	420	USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
[782]	421	! Input arguments
	422	!************************************************************************************
	423	INTEGER, INTENT(IN) :: ktime
	424
	425	! Output arguments
	426	!************************************************************************************
[4640]	427	REAL, DIMENSION(nbp_lon, jj_nb,maxrecv_phys), INTENT(OUT) :: tab_get
[782]	428
	429	! Local variables
	430	!************************************************************************************
	431	INTEGER :: ierror, i
	432	INTEGER :: istart,iend
	433	CHARACTER (len = 20) :: modname = 'fromcpl'
	434	CHARACTER (len = 80) :: abort_message
[2346]	435	REAL, DIMENSION(nbp_lon*jj_nb) :: field
[782]	436
	437	!************************************************************************************
[1279]	438	WRITE (lunout,*) ' '
	439	WRITE (lunout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime
	440	WRITE (lunout,*) ' '
[782]	441
	442	istart=ii_begin
[2429]	443	IF (is_south_pole_dyn) THEN
[2346]	444	iend=(jj_end-jj_begin)*nbp_lon+nbp_lon
[782]	445	ELSE
[2346]	446	iend=(jj_end-jj_begin)*nbp_lon+ii_end
[782]	447	ENDIF
	448
[4640]	449	DO i = 1, maxrecv_phys
[1965]	450	IF (inforecv(i)%action .AND. inforecv(i)%nid .NE. -1) THEN
[1279]	451	field(:) = -99999.
	452	CALL prism_get_proto(inforecv(i)%nid, ktime, field(istart:iend), ierror)
[2346]	453	tab_get(:,:,i) = RESHAPE(field(:),(/nbp_lon,jj_nb/))
[782]	454
[1279]	455	IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Recvd .AND. &
	456	ierror.NE.PRISM_FromRest &
	457	.AND. ierror.NE.PRISM_Input .AND. ierror.NE.PRISM_RecvOut &
	458	.AND. ierror.NE.PRISM_FromRestOut) THEN
	459	WRITE (lunout,*) 'Error with receiving filed : ', inforecv(i)%name, ktime
	460	abort_message=' Problem in prism_get_proto '
[2311]	461	CALL abort_physic(modname,abort_message,1)
[1279]	462	ENDIF
	463	ENDIF
[782]	464	END DO
	465
	466
	467	END SUBROUTINE fromcpl
	468
	469	!
	470	!************************************************************************************
	471	!
	472
	473	SUBROUTINE intocpl(ktime, last, tab_put)
	474	! ======================================================================
	475	! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the
	476	! atmospheric coupling fields to the coupler with the psmile library.
	477	! IF last time step, writes output fields to binary files.
	478	! ======================================================================
	479	!
	480	!
[2311]	481	USE print_control_mod, ONLY: lunout
[2371]	482	USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
[782]	483	! Input arguments
	484	!************************************************************************************
[1279]	485	INTEGER, INTENT(IN) :: ktime
	486	LOGICAL, INTENT(IN) :: last
[5654]	487	REAL, DIMENSION(nbp_lon, jj_nb, maxsend_phys), INTENT(IN) :: tab_put
[782]	488
	489	! Local variables
	490	!************************************************************************************
[987]	491	LOGICAL :: checkout
	492	INTEGER :: istart,iend
	493	INTEGER :: wstart,wend
	494	INTEGER :: ierror, i
[2346]	495	REAL, DIMENSION(nbp_lon*jj_nb) :: field
[987]	496	CHARACTER (len = 20),PARAMETER :: modname = 'intocpl'
	497	CHARACTER (len = 80) :: abort_message
[782]	498
	499	!************************************************************************************
[987]	500	checkout=.FALSE.
[782]	501
[1279]	502	WRITE(lunout,*) ' '
	503	WRITE(lunout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime
	504	WRITE(lunout,*) 'last = ', last
	505	WRITE(lunout,*)
[782]	506
	507
	508	istart=ii_begin
[2429]	509	IF (is_south_pole_dyn) THEN
[2346]	510	iend=(jj_end-jj_begin)*nbp_lon+nbp_lon
[782]	511	ELSE
[2346]	512	iend=(jj_end-jj_begin)*nbp_lon+ii_end
[782]	513	ENDIF
	514
	515	IF (checkout) THEN
	516	wstart=istart
	517	wend=iend
[2429]	518	IF (is_north_pole_dyn) wstart=istart+nbp_lon-1
	519	IF (is_south_pole_dyn) wend=iend-nbp_lon+1
[782]	520
[5654]	521	DO i = 1, maxsend_phys
[1279]	522	IF (infosend(i)%action) THEN
[2346]	523	field = RESHAPE(tab_put(:,:,i),(/nbp_lon*jj_nb/))
[1279]	524	CALL writefield_phy(infosend(i)%name,field(wstart:wend),1)
	525	END IF
	526	END DO
	527	END IF
	528
[782]	529	!************************************************************************************
	530	! PRISM_PUT
	531	!************************************************************************************
	532
[5654]	533	DO i = 1, maxsend_phys
[1965]	534	IF (infosend(i)%action .AND. infosend(i)%nid .NE. -1 ) THEN
[2346]	535	field = RESHAPE(tab_put(:,:,i),(/nbp_lon*jj_nb/))
[1279]	536	CALL prism_put_proto(infosend(i)%nid, ktime, field(istart:iend), ierror)
	537
	538	IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Sent .AND. ierror.NE.PRISM_ToRest &
	539	.AND. ierror.NE.PRISM_LocTrans .AND. ierror.NE.PRISM_Output .AND. &
	540	ierror.NE.PRISM_SentOut .AND. ierror.NE.PRISM_ToRestOut) THEN
	541	WRITE (lunout,*) 'Error with sending field :', infosend(i)%name, ktime
	542	abort_message=' Problem in prism_put_proto '
[2311]	543	CALL abort_physic(modname,abort_message,1)
[1279]	544	ENDIF
	545	ENDIF
[782]	546	END DO
	547
	548	!************************************************************************************
	549	! Finalize PSMILE for the case is_sequential, if parallel finalization is done
	550	! from Finalize_parallel in dyn3dpar/parallel.F90
	551	!************************************************************************************
	552
	553	IF (last) THEN
	554	IF (is_sequential) THEN
	555	CALL prism_terminate_proto(ierror)
	556	IF (ierror .NE. PRISM_Ok) THEN
[1279]	557	abort_message=' Problem in prism_terminate_proto '
[2311]	558	CALL abort_physic(modname,abort_message,1)
[782]	559	ENDIF
	560	ENDIF
	561	ENDIF
	562
	563
	564	END SUBROUTINE intocpl
	565
	566	#endif
	567
	568	END MODULE oasis

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

Download in other formats:

Original Format