Context Navigation

iostart.F90 @ 5433

Last change on this file since 5433 was 3411, checked in by Laurent Fairhead, 6 years ago
Undoing merge with trunk (r3356) to properly register Yann's latest modifications
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: 14.3 KB

Rev	Line
[1001]	1	MODULE iostart
	2
	3	PRIVATE
	4	INTEGER,SAVE :: nid_start
	5	INTEGER,SAVE :: nid_restart
	6
[1403]	7	INTEGER,SAVE :: idim1,idim2,idim3,idim4
[1001]	8	INTEGER,PARAMETER :: length=100
	9
	10	INTERFACE get_field
	11	MODULE PROCEDURE Get_field_r1,Get_field_r2,Get_field_r3
	12	END INTERFACE get_field
	13
	14	INTERFACE get_var
	15	MODULE PROCEDURE get_var_r0,Get_var_r1,Get_var_r2,Get_var_r3
	16	END INTERFACE get_var
	17
	18	INTERFACE put_field
	19	MODULE PROCEDURE put_field_r1,put_field_r2,put_field_r3
	20	END INTERFACE put_field
	21
	22	INTERFACE put_var
	23	MODULE PROCEDURE put_var_r0,put_var_r1,put_var_r2,put_var_r3
	24	END INTERFACE put_var
	25
	26	PUBLIC get_field,get_var,put_field,put_var
	27	PUBLIC Open_startphy,close_startphy,open_restartphy,close_restartphy
	28
	29	CONTAINS
	30
	31	SUBROUTINE Open_startphy(filename)
	32	USE netcdf
	33	USE mod_phys_lmdz_para
	34	IMPLICIT NONE
	35	CHARACTER(LEN=*) :: filename
	36	INTEGER :: ierr
	37
	38	IF (is_mpi_root .AND. is_omp_root) THEN
	39	ierr = NF90_OPEN (filename, NF90_NOWRITE,nid_start)
	40	IF (ierr.NE.NF90_NOERR) THEN
	41	write(6,*)' Pb d''ouverture du fichier '//filename
	42	write(6,*)' ierr = ', ierr
[2311]	43	CALL abort_physic("", "", 1)
[1001]	44	ENDIF
	45	ENDIF
	46
	47	END SUBROUTINE Open_startphy
	48
	49	SUBROUTINE Close_startphy
	50	USE netcdf
	51	USE mod_phys_lmdz_para
	52	IMPLICIT NONE
	53	INTEGER :: ierr
	54
	55	IF (is_mpi_root .AND. is_omp_root) THEN
	56	ierr = NF90_CLOSE (nid_start)
	57	ENDIF
	58
	59	END SUBROUTINE close_startphy
	60
	61
	62	FUNCTION Inquire_Field(Field_name)
	63	USE netcdf
	64	USE mod_phys_lmdz_para
	65	IMPLICIT NONE
	66	CHARACTER(LEN=*) :: Field_name
	67	LOGICAL :: inquire_field
	68	INTEGER :: varid
	69	INTEGER :: ierr
	70
	71	IF (is_mpi_root .AND. is_omp_root) THEN
	72	ierr=NF90_INQ_VARID(nid_start,Field_name,varid)
	73	IF (ierr==NF90_NOERR) THEN
	74	Inquire_field=.TRUE.
	75	ELSE
	76	Inquire_field=.FALSE.
	77	ENDIF
	78	ENDIF
	79
	80	CALL bcast(Inquire_field)
	81
	82	END FUNCTION Inquire_Field
	83
	84
	85	SUBROUTINE Get_Field_r1(field_name,field,found)
	86	IMPLICIT NONE
	87	CHARACTER(LEN=*),INTENT(IN) :: Field_name
	88	REAL,INTENT(INOUT) :: Field(:)
	89	LOGICAL,INTENT(OUT),OPTIONAL :: found
	90
[3411]	91	IF (PRESENT(found)) THEN
	92	CALL Get_field_rgen(field_name,field,1,found)
	93	ELSE
	94	CALL Get_field_rgen(field_name,field,1)
	95	ENDIF
[1001]	96
	97	END SUBROUTINE Get_Field_r1
	98
	99	SUBROUTINE Get_Field_r2(field_name,field,found)
	100	IMPLICIT NONE
	101	CHARACTER(LEN=*),INTENT(IN) :: Field_name
	102	REAL,INTENT(INOUT) :: Field(:,:)
	103	LOGICAL,INTENT(OUT),OPTIONAL :: found
	104
[3411]	105	IF (PRESENT(found)) THEN
	106	CALL Get_field_rgen(field_name,field,size(field,2),found)
	107	ELSE
	108	CALL Get_field_rgen(field_name,field,size(field,2))
	109	ENDIF
[1001]	110
	111
	112	END SUBROUTINE Get_Field_r2
	113
	114	SUBROUTINE Get_Field_r3(field_name,field,found)
	115	IMPLICIT NONE
	116	CHARACTER(LEN=*),INTENT(IN) :: Field_name
	117	REAL,INTENT(INOUT) :: Field(:,:,:)
	118	LOGICAL,INTENT(OUT),OPTIONAL :: found
	119
[3411]	120	IF (PRESENT(found)) THEN
	121	CALL Get_field_rgen(field_name,field,size(field,2)*size(field,3),found)
	122	ELSE
	123	CALL Get_field_rgen(field_name,field,size(field,2)*size(field,3))
	124	ENDIF
[1001]	125
	126	END SUBROUTINE Get_Field_r3
	127
	128	SUBROUTINE Get_field_rgen(field_name,field,field_size,found)
	129	USE netcdf
	130	USE dimphy
[3312]	131	USE geometry_mod
[1001]	132	USE mod_grid_phy_lmdz
	133	USE mod_phys_lmdz_para
	134	IMPLICIT NONE
	135	CHARACTER(LEN=*) :: Field_name
	136	INTEGER :: field_size
	137	REAL :: field(klon,field_size)
	138	LOGICAL,OPTIONAL :: found
	139
	140	REAL :: field_glo(klon_glo,field_size)
[3312]	141	REAL :: field_glo_tmp(klon_glo,field_size)
	142	INTEGER :: ind_cell_glo_glo(klon_glo)
[1001]	143	LOGICAL :: tmp_found
	144	INTEGER :: varid
[3312]	145	INTEGER :: ierr,i
	146
	147	! IF (is_master) ALLOCATE(ind_cell_glo_glo(1:klon_glo))
	148	CALL gather(ind_cell_glo,ind_cell_glo_glo)
[1001]	149
[3312]	150	IF (is_master) THEN
[1001]	151
	152	ierr=NF90_INQ_VARID(nid_start,Field_name,varid)
	153
	154	IF (ierr==NF90_NOERR) THEN
[3312]	155	CALL body(field_glo_tmp)
[1001]	156	tmp_found=.TRUE.
	157	ELSE
	158	tmp_found=.FALSE.
	159	ENDIF
	160
	161	ENDIF
	162
	163	CALL bcast(tmp_found)
	164
	165	IF (tmp_found) THEN
[3312]	166	IF (is_master) THEN
	167	DO i=1,klon_glo
	168	field_glo(i,:)=field_glo_tmp(ind_cell_glo_glo(i),:)
	169	ENDDO
	170	ENDIF
[1001]	171	CALL scatter(field_glo,field)
	172	ENDIF
	173
	174	IF (PRESENT(found)) THEN
	175	found=tmp_found
	176	ELSE
	177	IF (.NOT. tmp_found) THEN
	178	PRINT*, 'phyetat0: Le champ <'//field_name//'> est absent'
[2311]	179	call abort_physic("", "", 1)
[1001]	180	ENDIF
	181	ENDIF
	182
	183
	184	CONTAINS
	185
	186	SUBROUTINE body(field_glo)
	187	REAL :: field_glo(klon_glo*field_size)
	188	ierr=NF90_GET_VAR(nid_start,varid,field_glo)
	189	IF (ierr/=NF90_NOERR) THEN
[1619]	190	! La variable exist dans le fichier mais la lecture a echouee.
[1001]	191	PRINT*, 'phyetat0: Lecture echouee pour <'//field_name//'>'
[1619]	192
	193	IF (field_name=='CLWCON' .OR. field_name=='RNEBCON' .OR. field_name=='RATQS') THEN
	194	! Essaye de lire le variable sur surface uniqument, comme fait avant
	195	field_glo(:)=0.
	196	ierr=NF90_GET_VAR(nid_start,varid,field_glo(1:klon_glo))
	197	IF (ierr/=NF90_NOERR) THEN
	198	PRINT*, 'phyetat0: Lecture echouee aussi en 2D pour <'//field_name//'>'
[2311]	199	call abort_physic("", "", 1)
[1619]	200	ELSE
	201	PRINT*, 'phyetat0: La variable <'//field_name//'> lu sur surface seulement'!, selon ancien format, le reste mis a zero'
	202	END IF
	203	ELSE
[2311]	204	call abort_physic("", "", 1)
[1619]	205	ENDIF
[1001]	206	ENDIF
	207
	208	END SUBROUTINE body
	209
	210	END SUBROUTINE Get_field_rgen
	211
	212
	213	SUBROUTINE get_var_r0(var_name,var,found)
	214	IMPLICIT NONE
	215	CHARACTER(LEN=*),INTENT(IN) :: var_name
	216	REAL,INTENT(INOUT) :: var
	217	LOGICAL,OPTIONAL,INTENT(OUT) :: found
	218
	219	REAL :: varout(1)
	220
[3411]	221	IF (PRESENT(found)) THEN
	222	CALL Get_var_rgen(var_name,varout,size(varout),found)
	223	ELSE
	224	CALL Get_var_rgen(var_name,varout,size(varout))
	225	ENDIF
[1001]	226	var=varout(1)
	227
	228	END SUBROUTINE get_var_r0
	229
	230	SUBROUTINE get_var_r1(var_name,var,found)
	231	IMPLICIT NONE
	232	CHARACTER(LEN=*),INTENT(IN) :: var_name
	233	REAL,INTENT(INOUT) :: var(:)
	234	LOGICAL,OPTIONAL,INTENT(OUT) :: found
	235
[3411]	236	IF (PRESENT(found)) THEN
	237	CALL Get_var_rgen(var_name,var,size(var),found)
	238	ELSE
	239	CALL Get_var_rgen(var_name,var,size(var))
	240	ENDIF
[1001]	241
	242	END SUBROUTINE get_var_r1
	243
	244	SUBROUTINE get_var_r2(var_name,var,found)
	245	IMPLICIT NONE
	246	CHARACTER(LEN=*),INTENT(IN) :: var_name
	247	REAL,INTENT(OUT) :: var(:,:)
	248	LOGICAL,OPTIONAL,INTENT(OUT) :: found
	249
[3411]	250	IF (PRESENT(found)) THEN
	251	CALL Get_var_rgen(var_name,var,size(var),found)
	252	ELSE
	253	CALL Get_var_rgen(var_name,var,size(var))
	254	ENDIF
[1001]	255
	256	END SUBROUTINE get_var_r2
	257
	258	SUBROUTINE get_var_r3(var_name,var,found)
	259	IMPLICIT NONE
	260	CHARACTER(LEN=*),INTENT(IN) :: var_name
	261	REAL,INTENT(INOUT) :: var(:,:,:)
	262	LOGICAL,OPTIONAL,INTENT(OUT) :: found
	263
[3411]	264	IF (PRESENT(found)) THEN
	265	CALL Get_var_rgen(var_name,var,size(var),found)
	266	ELSE
	267	CALL Get_var_rgen(var_name,var,size(var))
	268	ENDIF
[1001]	269
	270	END SUBROUTINE get_var_r3
	271
	272	SUBROUTINE Get_var_rgen(var_name,var,var_size,found)
	273	USE netcdf
	274	USE dimphy
	275	USE mod_grid_phy_lmdz
	276	USE mod_phys_lmdz_para
	277	IMPLICIT NONE
	278	CHARACTER(LEN=*) :: var_name
	279	INTEGER :: var_size
	280	REAL :: var(var_size)
	281	LOGICAL,OPTIONAL :: found
	282
	283	LOGICAL :: tmp_found
	284	INTEGER :: varid
	285	INTEGER :: ierr
	286
	287	IF (is_mpi_root .AND. is_omp_root) THEN
	288
	289	ierr=NF90_INQ_VARID(nid_start,var_name,varid)
	290
	291	IF (ierr==NF90_NOERR) THEN
	292	ierr=NF90_GET_VAR(nid_start,varid,var)
	293	IF (ierr/=NF90_NOERR) THEN
	294	PRINT*, 'phyetat0: Lecture echouee pour <'//var_name//'>'
[2311]	295	call abort_physic("", "", 1)
[1001]	296	ENDIF
	297	tmp_found=.TRUE.
	298	ELSE
	299	tmp_found=.FALSE.
	300	ENDIF
	301
	302	ENDIF
	303
	304	CALL bcast(tmp_found)
	305
	306	IF (tmp_found) THEN
	307	CALL bcast(var)
	308	ENDIF
	309
	310	IF (PRESENT(found)) THEN
	311	found=tmp_found
	312	ELSE
	313	IF (.NOT. tmp_found) THEN
	314	PRINT*, 'phyetat0: La variable champ <'//var_name//'> est absente'
[2311]	315	call abort_physic("", "", 1)
[1001]	316	ENDIF
	317	ENDIF
	318
	319	END SUBROUTINE Get_var_rgen
	320
	321
	322	SUBROUTINE open_restartphy(filename)
	323	USE netcdf
	324	USE mod_phys_lmdz_para
	325	USE mod_grid_phy_lmdz
	326	USE dimphy
	327	IMPLICIT NONE
	328	CHARACTER(LEN=*),INTENT(IN) :: filename
	329	INTEGER :: ierr
	330
	331	IF (is_mpi_root .AND. is_omp_root) THEN
	332	ierr = NF90_CREATE(filename, NF90_CLOBBER, nid_restart)
	333	IF (ierr/=NF90_NOERR) THEN
	334	write(6,*)' Pb d''ouverture du fichier '//filename
	335	write(6,*)' ierr = ', ierr
[2311]	336	CALL abort_physic("", "", 1)
[1001]	337	ENDIF
	338
	339	ierr = NF90_PUT_ATT (nid_restart, NF90_GLOBAL, "title","Fichier redemmarage physique")
	340
	341	ierr = NF90_DEF_DIM (nid_restart, "index", length, idim1)
	342	ierr = NF90_DEF_DIM (nid_restart, "points_physiques", klon_glo, idim2)
	343	ierr = NF90_DEF_DIM (nid_restart, "horizon_vertical", klon_glo*klev, idim3)
[1403]	344	ierr = NF90_DEF_DIM (nid_restart, "horizon_klevp1", klon_glo*klevp1, idim4)
[1001]	345
	346	ierr = NF90_ENDDEF(nid_restart)
	347	ENDIF
	348
	349	END SUBROUTINE open_restartphy
	350
	351	SUBROUTINE close_restartphy
	352	USE netcdf
	353	USE mod_phys_lmdz_para
	354	IMPLICIT NONE
	355	INTEGER :: ierr
	356
	357	IF (is_mpi_root .AND. is_omp_root) THEN
	358	ierr = NF90_CLOSE (nid_restart)
	359	ENDIF
	360
	361	END SUBROUTINE close_restartphy
	362
	363
	364	SUBROUTINE put_field_r1(field_name,title,field)
	365	IMPLICIT NONE
	366	CHARACTER(LEN=*),INTENT(IN) :: field_name
	367	CHARACTER(LEN=*),INTENT(IN) :: title
	368	REAL,INTENT(IN) :: field(:)
	369
	370	CALL put_field_rgen(field_name,title,field,1)
	371
	372	END SUBROUTINE put_field_r1
	373
	374	SUBROUTINE put_field_r2(field_name,title,field)
	375	IMPLICIT NONE
	376	CHARACTER(LEN=*),INTENT(IN) :: field_name
	377	CHARACTER(LEN=*),INTENT(IN) :: title
	378	REAL,INTENT(IN) :: field(:,:)
	379
	380	CALL put_field_rgen(field_name,title,field,size(field,2))
	381
	382	END SUBROUTINE put_field_r2
	383
	384	SUBROUTINE put_field_r3(field_name,title,field)
	385	IMPLICIT NONE
	386	CHARACTER(LEN=*),INTENT(IN) :: field_name
	387	CHARACTER(LEN=*),INTENT(IN) :: title
	388	REAL,INTENT(IN) :: field(:,:,:)
	389
	390	CALL put_field_rgen(field_name,title,field,size(field,2)*size(field,3))
	391
	392	END SUBROUTINE put_field_r3
	393
	394	SUBROUTINE put_field_rgen(field_name,title,field,field_size)
	395	USE netcdf
	396	USE dimphy
[3312]	397	USE geometry_mod
[1001]	398	USE mod_grid_phy_lmdz
	399	USE mod_phys_lmdz_para
	400	IMPLICIT NONE
	401	CHARACTER(LEN=*),INTENT(IN) :: field_name
	402	CHARACTER(LEN=*),INTENT(IN) :: title
	403	INTEGER,INTENT(IN) :: field_size
	404	REAL,INTENT(IN) :: field(klon,field_size)
	405
	406	REAL :: field_glo(klon_glo,field_size)
[3312]	407	REAL :: field_glo_tmp(klon_glo,field_size)
	408	! INTEGER,ALLOCATABLE :: ind_cell_glo_glo(:)
	409	INTEGER :: ind_cell_glo_glo(klon_glo)
	410	INTEGER :: ierr,i
[1001]	411	INTEGER :: nvarid
	412	INTEGER :: idim
	413
	414
[3312]	415	! IF (is_master) ALLOCATE(ind_cell_glo_glo(klon_glo))
	416	CALL gather(ind_cell_glo,ind_cell_glo_glo)
	417
	418	CALL gather(field,field_glo_tmp)
[1001]	419
[3312]	420	IF (is_master) THEN
[1403]	421
[3312]	422	DO i=1,klon_glo
	423	field_glo(ind_cell_glo_glo(i),:)=field_glo_tmp(i,:)
	424	ENDDO
	425
	426
[1001]	427	IF (field_size==1) THEN
	428	idim=idim2
	429	ELSE IF (field_size==klev) THEN
	430	idim=idim3
[1403]	431	ELSE IF (field_size==klevp1) THEN
	432	idim=idim4
[1001]	433	ELSE
	434	PRINT *, "erreur phyredem : probleme de dimension"
[2311]	435	CALL abort_physic("", "", 1)
[1001]	436	ENDIF
	437
	438	ierr = NF90_REDEF (nid_restart)
	439	#ifdef NC_DOUBLE
	440	ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_DOUBLE,(/ idim /),nvarid)
	441	#else
	442	ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_FLOAT,(/ idim /),nvarid)
	443	#endif
	444	IF (LEN_TRIM(title) > 0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
	445	ierr = NF90_ENDDEF(nid_restart)
	446	ierr = NF90_PUT_VAR(nid_restart,nvarid,RESHAPE(field_glo,(/klon_glo*field_size/)))
	447	ENDIF
	448
	449	END SUBROUTINE put_field_rgen
	450
	451	SUBROUTINE put_var_r0(var_name,title,var)
	452	IMPLICIT NONE
	453	CHARACTER(LEN=*),INTENT(IN) :: var_name
	454	CHARACTER(LEN=*),INTENT(IN) :: title
	455	REAL,INTENT(IN) :: var
	456	REAL :: varin(1)
	457
	458	varin(1)=var
	459
	460	CALL put_var_rgen(var_name,title,varin,size(varin))
	461
	462	END SUBROUTINE put_var_r0
	463
	464
	465	SUBROUTINE put_var_r1(var_name,title,var)
	466	IMPLICIT NONE
	467	CHARACTER(LEN=*),INTENT(IN) :: var_name
	468	CHARACTER(LEN=*),INTENT(IN) :: title
	469	REAL,INTENT(IN) :: var(:)
	470
	471	CALL put_var_rgen(var_name,title,var,size(var))
	472
	473	END SUBROUTINE put_var_r1
	474
	475	SUBROUTINE put_var_r2(var_name,title,var)
	476	IMPLICIT NONE
	477	CHARACTER(LEN=*),INTENT(IN) :: var_name
	478	CHARACTER(LEN=*),INTENT(IN) :: title
	479	REAL,INTENT(IN) :: var(:,:)
	480
	481	CALL put_var_rgen(var_name,title,var,size(var))
	482
	483	END SUBROUTINE put_var_r2
	484
	485	SUBROUTINE put_var_r3(var_name,title,var)
	486	IMPLICIT NONE
	487	CHARACTER(LEN=*),INTENT(IN) :: var_name
	488	CHARACTER(LEN=*),INTENT(IN) :: title
	489	REAL,INTENT(IN) :: var(:,:,:)
	490
	491	CALL put_var_rgen(var_name,title,var,size(var))
	492
	493	END SUBROUTINE put_var_r3
	494
	495	SUBROUTINE put_var_rgen(var_name,title,var,var_size)
	496	USE netcdf
	497	USE dimphy
	498	USE mod_phys_lmdz_para
	499	IMPLICIT NONE
	500	CHARACTER(LEN=*),INTENT(IN) :: var_name
	501	CHARACTER(LEN=*),INTENT(IN) :: title
	502	INTEGER,INTENT(IN) :: var_size
	503	REAL,INTENT(IN) :: var(var_size)
	504
	505	INTEGER :: ierr
	506	INTEGER :: nvarid
	507
	508	IF (is_mpi_root .AND. is_omp_root) THEN
[1403]	509
[1001]	510	IF (var_size/=length) THEN
	511	PRINT *, "erreur phyredem : probleme de dimension"
[2311]	512	call abort_physic("", "", 1)
[1001]	513	ENDIF
	514
	515	ierr = NF90_REDEF (nid_restart)
	516
	517	#ifdef NC_DOUBLE
	518	ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_DOUBLE,(/ idim1 /),nvarid)
	519	#else
	520	ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_FLOAT,(/ idim1 /),nvarid)
	521	#endif
	522	IF (LEN_TRIM(title)>0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
	523	ierr = NF90_ENDDEF(nid_restart)
	524
	525	ierr = NF90_PUT_VAR(nid_restart,nvarid,var)
	526
	527	ENDIF
	528
	529	END SUBROUTINE put_var_rgen
	530
	531	END MODULE iostart

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

Download in other formats:

Original Format