Context Navigation

oasis.F90 @ 4926

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

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

Download in other formats:

Original Format