Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

iom_rstdimg.F90 @ 9295

Last change on this file since 9295 was 9295, checked in by jcastill, 6 years ago
Remove svn keywords
File size: 28.2 KB

Rev	Line
[544]	1	MODULE iom_rstdimg
	2	!!=====================================================================
	3	!! * MODULE iom_rstdimg *
	4	!! Input/Output manager : Library to read input rstdimg files
	5	!!====================================================================
	6	!! History : 9.0 ! 06 09 (S. Masson) Original code
	7	!!--------------------------------------------------------------------
	8
	9	!!--------------------------------------------------------------------
	10	!! iom_open : open a file read only
	11	!! iom_close : close a file or all files opened by iom
	12	!! iom_get : read a field (interfaced to several routines)
	13	!! iom_gettime : read the time axis kvid in the file
	14	!! iom_varid : get the id of a variable in a file
	15	!! iom_rstput : write a field in a restart file (interfaced to several routines)
	16	!!--------------------------------------------------------------------
	17	USE in_out_manager ! I/O manager
[2715]	18	USE lib_mpp ! MPP library
[544]	19	USE dom_oce ! ocean space and time domain
	20	USE lbclnk ! lateal boundary condition / mpp exchanges
[556]	21	USE iom_def ! iom variables definitions
[544]	22
	23	IMPLICIT NONE
	24	PRIVATE
	25
	26	PUBLIC iom_rstdimg_open, iom_rstdimg_close, iom_rstdimg_get, iom_rstdimg_rstput
	27
	28	INTERFACE iom_rstdimg_get
[550]	29	MODULE PROCEDURE iom_rstdimg_g0d, iom_rstdimg_g123d
[544]	30	END INTERFACE
	31	INTERFACE iom_rstdimg_rstput
[550]	32	MODULE PROCEDURE iom_rstdimg_rp0d, iom_rstdimg_rp123d
[544]	33	END INTERFACE
[588]	34
	35	INTEGER, PARAMETER :: jpvnl = 32 ! variable name length
	36
[544]	37	!!----------------------------------------------------------------------
[2528]	38	!! NEMO/OPA 3.3 , NEMO Consortium (2010)
[1152]	39	!! $Id$
[2528]	40	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
[544]	41	!!----------------------------------------------------------------------
	42
	43	CONTAINS
	44
	45	SUBROUTINE iom_rstdimg_open( cdname, kiomid, ldwrt, ldok, kdompar )
	46	!!---------------------------------------------------------------------
	47	!! * SUBROUTINE iom_open *
	48	!!
	49	!! ** Purpose : open an input file read only (return 0 if not found)
	50	!!---------------------------------------------------------------------
[1488]	51	CHARACTER(len=*) , INTENT(inout) :: cdname ! File name
	52	INTEGER , INTENT( out) :: kiomid ! iom identifier of the opened file
	53	LOGICAL , INTENT(in ) :: ldwrt ! read or write the file?
	54	LOGICAL , INTENT(in ) :: ldok ! check the existence
	55	INTEGER, DIMENSION(2,5), INTENT(in ), OPTIONAL :: kdompar ! domain parameters:
[544]	56
	57	CHARACTER(LEN=100) :: clinfo ! info character
	58	CHARACTER(LEN=100) :: cltmp ! temporary character
[1488]	59	CHARACTER(LEN=10 ) :: clstatus ! status of opened file (REPLACE or NEW)
[544]	60	INTEGER :: jv ! loop counter
	61	INTEGER :: istop ! temporary storage of nstop
	62	INTEGER :: idrst ! logical unit of the restart file
	63	INTEGER :: iln ! lengths of character
	64	INTEGER :: irecl8 ! record length
	65	INTEGER :: ios ! IO status
[588]	66	INTEGER :: irhd ! record of the header infos
[544]	67	INTEGER :: ivnum ! number of variables
[550]	68	INTEGER :: ishft ! counter shift
[544]	69	INTEGER :: inx, iny, inz ! x,y,z dimension of the variable
[550]	70	INTEGER :: in0d, in1d, in2d, in3d ! number of 0/1/2/3D variables
[544]	71	INTEGER :: ipni, ipnj, ipnij, iarea ! domain decomposition
[611]	72	INTEGER :: iiglo, ijglo ! domain global size
[588]	73	INTEGER :: jl ! loop variable
[1488]	74	LOGICAL :: llclobber ! local definition of ln_clobber
[588]	75	CHARACTER(LEN=jpvnl), DIMENSION(jpmax_vars) :: clna0d, clna1d, clna2d, clna3d ! name of 0/1/2/3D variables
[1488]	76	REAL(wp), DIMENSION(jpmax_vars) :: zval0d, zval1d, zval2d, zval3d ! value of 0d variables or record
	77	! ! position for 1/2/3D variables
[544]	78	!---------------------------------------------------------------------
	79	clinfo = ' iom_rstdimg_open ~~~ '
	80	istop = nstop ! store the actual value of nstop
	81	ios = 0 ! default definition
	82	kiomid = 0 ! default definition
[1488]	83	llclobber = ldwrt .AND. ln_clobber
[544]	84	! get a free unit
[2715]	85	idrst = get_unit() ! get a free logical unit for the restart file
[544]	86	!!$#if defined key_agrif
	87	!!$ idrst = Agrif_Get_Unit()
	88	!!$#endif
	89	! Open the file...
	90	! =============
[1488]	91	IF( ldok .AND. .NOT. llclobber ) THEN ! Open existing file...
[544]	92	! find the record length
	93	OPEN( idrst, FILE = TRIM(cdname), FORM = 'unformatted', ACCESS = 'direct' &
[550]	94	& , RECL = 8, STATUS = 'old', ACTION = 'read', IOSTAT = ios, ERR = 987 )
[544]	95	READ( idrst, REC = 1, IOSTAT = ios, ERR = 987 ) irecl8
	96	CLOSE( idrst )
	97	! Open the file with the appropriate record length and parameters
	98	IF( ldwrt ) THEN ! ... in readwrite mode
	99	IF(lwp) WRITE(numout,*) TRIM(clinfo)//' open existing file: '//TRIM(cdname)//' in READWRITE mode'
	100	OPEN( idrst, FILE = TRIM(cdname), FORM = 'unformatted', ACCESS = 'direct' &
[550]	101	& , RECL = irecl8, STATUS = 'old', ACTION = 'readwrite', IOSTAT = ios, ERR = 987 )
[544]	102	ELSE ! ... in read mode
	103	IF(lwp) WRITE(numout,*) TRIM(clinfo)//' open existing file: '//TRIM(cdname)//' in READ mode'
	104	OPEN( idrst, FILE = TRIM(cdname), FORM = 'unformatted', ACCESS = 'direct' &
[550]	105	& , RECL = irecl8, STATUS = 'old', ACTION = 'read' , IOSTAT = ios, ERR = 987 )
[544]	106	ENDIF
[1488]	107	ELSE ! the file does not exist (or we overwrite it)
[544]	108	iln = INDEX( cdname, '.dimg' )
	109	IF( ldwrt ) THEN ! the file should be open in readwrite mode so we create it...
[588]	110	irecl8= MAX( kdompar(1,1) * kdompar(2,1) * wp, ( 8jpnij + 15 ) 4 )
[550]	111	IF( jpnij > 1 ) THEN
[741]	112	WRITE(cltmp,'(a,a,i4.4,a)') cdname(1:iln-1), '_', narea, '.dimg'
[550]	113	cdname = TRIM(cltmp)
	114	ENDIF
[544]	115	IF(lwp) WRITE(numout,*) TRIM(clinfo)//' create new file: '//TRIM(cdname)//' in READWRITE mode'
[1488]	116
	117	IF( llclobber ) THEN ; clstatus = 'REPLACE'
	118	ELSE ; clstatus = 'NEW'
	119	ENDIF
[544]	120	OPEN( idrst, FILE = TRIM(cdname), FORM = 'UNFORMATTED', ACCESS = 'DIRECT' &
[1488]	121	& , RECL = irecl8, STATUS = TRIM(clstatus), ACTION = 'readwrite', IOSTAT = ios, ERR = 987 )
[544]	122	ELSE ! the file should be open for read mode so it must exist...
[679]	123	CALL ctl_stop( TRIM(clinfo), ' should be impossible case...' )
[544]	124	ENDIF
	125	ENDIF
	126	! Performs checks on the file
	127	! =============
[1488]	128	IF( ldok .AND. .NOT. llclobber ) THEN ! old file
[611]	129	READ( idrst, REC = 1 , IOSTAT = ios, ERR = 987 ) &
	130	& irecl8, inx, iny, inz, in0d, in1d, in2d, in3d, irhd, &
	131	& ipni, ipnj, ipnij, iarea, iiglo, ijglo
	132	READ( idrst, REC = irhd, IOSTAT = ios, ERR = 987 ) &
[550]	133	& clna0d(1:in0d), zval0d(1:in0d), clna1d(1:in1d), zval1d(1:in1d), &
[611]	134	& clna2d(1:in2d), zval2d(1:in2d), clna3d(1:in3d), zval3d(1:in3d)
[544]	135	clinfo = TRIM(clinfo)//' file '//TRIM(cdname)
[611]	136	IF( iiglo /= jpiglo ) CALL ctl_stop( TRIM(clinfo), 'Mismatch in global domain size in i direction' )
	137	IF( ijglo /= jpjglo ) CALL ctl_stop( TRIM(clinfo), 'Mismatch in global domain size in j direction' )
[679]	138	IF( ldwrt ) THEN
	139	IF( inx /= kdompar(1,1) ) CALL ctl_stop( TRIM(clinfo), 'Mismatch in local domain size in i direction' )
	140	IF( iny /= kdompar(2,1) ) CALL ctl_stop( TRIM(clinfo), 'Mismatch in local domain size in j direction' )
	141	ENDIF
[544]	142	IF( inz /= jpk ) CALL ctl_stop( TRIM(clinfo), 'Mismatch in domain size in k direction' )
	143	IF( ipni /= jpni ) CALL ctl_stop( TRIM(clinfo), 'Processor splitting changed along I' )
	144	IF( ipnj /= jpnj ) CALL ctl_stop( TRIM(clinfo), 'Processor splitting changed along J' )
	145	IF( ipnij /= jpnij ) CALL ctl_stop( TRIM(clinfo), 'Total number of processors changed' )
	146	IF( iarea /= narea ) CALL ctl_stop( TRIM(clinfo), 'Mismatch in area numbering ...' )
	147	ENDIF
	148	! fill file informations
	149	! =============
	150	IF( istop == nstop ) THEN ! no error within this routine
[588]	151	!does not work with some compilers kiomid = MINLOC(iom_file(:)%nfid, dim = 1)
	152	kiomid = 0
	153	DO jl = jpmax_files, 1, -1
	154	IF( iom_file(jl)%nfid == 0 ) kiomid = jl
	155	ENDDO
[544]	156	iom_file(kiomid)%name = TRIM(cdname)
	157	iom_file(kiomid)%nfid = idrst
	158	iom_file(kiomid)%iolib = jprstdimg
	159	iom_file(kiomid)%iduld = -1
	160	IF( ldok ) THEN ! old file
	161	! read variables informations from the file header
[550]	162	IF( TRIM(clna0d(1)) == 'no0d' ) in0d = 0
	163	IF( TRIM(clna1d(1)) == 'no1d' ) in1d = 0
	164	IF( TRIM(clna2d(1)) == 'no2d' ) in2d = 0
	165	IF( TRIM(clna3d(1)) == 'no3d' ) in3d = 0
	166	ivnum = in0d + in1d + in2d + in3d
[544]	167	iom_file(kiomid)%nvars = ivnum
[550]	168	iom_file(kiomid)%irec = 2 + in1d + in2d + inz * in3d
[544]	169	iom_file(kiomid)%luld( 1:ivnum) = .FALSE.
	170	iom_file(kiomid)%scf( 1:ivnum) = 1.
	171	! scalar variable
	172	DO jv = 1, in0d
	173	iom_file(kiomid)%cn_var(jv) = TRIM(clna0d(jv))
	174	iom_file(kiomid)%nvid( jv) = 1
	175	iom_file(kiomid)%ndims( jv) = 0
	176	iom_file(kiomid)%ofs( jv) = zval0d(jv) ! warning: trick... we use ofs to store the value
	177	END DO
[550]	178	! 1d variable
	179	ishft = in0d
	180	DO jv = 1, in1d
	181	iom_file(kiomid)%cn_var( ishft + jv) = TRIM(clna1d(jv))
	182	iom_file(kiomid)%nvid( ishft + jv) = zval1d(jv)
	183	iom_file(kiomid)%ndims( ishft + jv) = 1
	184	iom_file(kiomid)%dimsz(1 , ishft + jv) = jpk
	185	iom_file(kiomid)%ofs( ishft + jv) = 0.
	186	END DO
[544]	187	! 2d variable
[550]	188	ishft = in0d + in1d
[544]	189	DO jv = 1, in2d
[550]	190	iom_file(kiomid)%cn_var( ishft + jv) = TRIM(clna2d(jv))
	191	iom_file(kiomid)%nvid( ishft + jv) = zval2d(jv)
	192	iom_file(kiomid)%ndims( ishft + jv) = 2
	193	iom_file(kiomid)%dimsz(1:2, ishft + jv) = (/ inx, iny /)
	194	iom_file(kiomid)%ofs( ishft + jv) = 0.
[544]	195	END DO
	196	! 3d variable
[550]	197	ishft = in0d + in1d + in2d
[544]	198	DO jv = 1, in3d
[550]	199	iom_file(kiomid)%cn_var( ishft + jv) = TRIM(clna3d(jv))
	200	iom_file(kiomid)%nvid( ishft + jv) = zval3d(jv)
	201	iom_file(kiomid)%ndims( ishft + jv) = 3
	202	iom_file(kiomid)%dimsz(1:3, ishft + jv) = (/ inx, iny, jpk /)
	203	iom_file(kiomid)%ofs( ishft + jv) = 0.
[544]	204	END DO
	205	ELSE ! new file
	206	iom_file(kiomid)%nvars = 0
	207	iom_file(kiomid)%irec = 2
	208	! store file informations
[547]	209	WRITE( idrst, REC = 1, IOSTAT = ios, ERR = 987 ) irecl8, kdompar(:,1), jpk ! store domain size
[544]	210	ENDIF
	211	ENDIF
	212	987 CONTINUE
[550]	213	IF( ios /= 0 ) THEN
	214	WRITE(ctmp1,*) ' iostat = ', ios
	215	CALL ctl_stop( TRIM(clinfo), ' error in opening file '//TRIM(cdname), ctmp1 )
	216	ENDIF
[544]	217	!
	218	END SUBROUTINE iom_rstdimg_open
	219
	220
	221	SUBROUTINE iom_rstdimg_close( kiomid )
	222	!!--------------------------------------------------------------------
	223	!! * SUBROUTINE iom_rstdimg_close *
	224	!!
	225	!! ** Purpose : close an input file
	226	!!--------------------------------------------------------------------
	227	INTEGER, INTENT(in) :: kiomid ! iom identifier of the file to be closed
	228	!
	229	CHARACTER(LEN=100) :: clinfo ! info character
	230	INTEGER :: jv ! loop counter
	231	INTEGER :: irecl8 ! record length
	232	INTEGER :: ios ! IO status
[588]	233	INTEGER :: irhd ! record of the header infos
[544]	234	INTEGER :: ivnum ! number of variables
	235	INTEGER :: idrst ! file logical unit
	236	INTEGER :: inx, iny, inz ! x,y,z dimension of the variable
[550]	237	INTEGER :: in0d, in1d, in2d, in3d ! number of 0/1/2/3D variables
[588]	238	CHARACTER(LEN=jpvnl), DIMENSION(jpmax_vars) :: clna0d, clna1d, clna2d, clna3d ! name of 0/1/2/3D variables
[584]	239	REAL(wp), DIMENSION(jpmax_vars) :: zval0d, zval1d, zval2d, zval3d ! value of 0d variables or record
[550]	240	! ! position for 1/2/3D variables
[544]	241	!---------------------------------------------------------------------
	242	!
	243	clinfo = ' iom_rstdimg_close ~~~ '
	244	idrst = iom_file(kiomid)%nfid ! get back the logical unit of the restart file
	245	! test if we can write in the file (test with INQUIRE gives alsways YES even with read only files...)
[547]	246	READ( idrst, REC = 1, IOSTAT = ios, ERR = 987 ) irecl8, inx, iny, inz
	247	WRITE( idrst, REC = 1, IOSTAT = ios ) irecl8, inx, iny, inz
	248	! We can write in the file => we update its header before closing
[544]	249	IF( ios == 0 ) THEN
[547]	250	READ( idrst, REC = 1, IOSTAT = ios, ERR = 987 ) irecl8, inx, iny, inz ! get back domain size
[588]	251	irhd = iom_file(kiomid)%irec
[544]	252	ivnum = iom_file(kiomid)%nvars
[550]	253	in0d = 0 ; in1d = 0 ; in2d = 0 ; in3d = 0
[544]	254	DO jv = 1, ivnum ! loop on each variable to get its name and value/record position
	255	SELECT CASE (iom_file(kiomid)%ndims(jv))
	256	CASE (0) ! scalar variable
	257	in0d = in0d + 1
	258	clna0d(in0d) = TRIM(iom_file(kiomid)%cn_var(jv))
	259	zval0d(in0d) = iom_file(kiomid)%ofs(jv) ! warning: trick... we use ofs to store the value
[550]	260	CASE (1) ! 1d variable
	261	in1d = in1d + 1
	262	clna1d(in1d) = TRIM(iom_file(kiomid)%cn_var(jv))
	263	zval1d(in1d) = iom_file(kiomid)%nvid(jv)
[544]	264	CASE (2) ! 2d variable
	265	in2d = in2d + 1
	266	clna2d(in2d) = TRIM(iom_file(kiomid)%cn_var(jv))
	267	zval2d(in2d) = iom_file(kiomid)%nvid(jv)
	268	CASE (3) ! 3d variable
	269	in3d = in3d + 1
	270	clna3d(in3d) = TRIM(iom_file(kiomid)%cn_var(jv))
	271	zval3d(in3d) = iom_file(kiomid)%nvid(jv)
[550]	272	CASE DEFAULT ; CALL ctl_stop( TRIM(clinfo), 'Should not ne there...' )
[544]	273	END SELECT
	274	END DO
[588]	275	! force to have at least 1 variable in each list (not necessary (?), but safer...)
[550]	276	IF( in0d == 0 ) THEN ; in0d = 1 ; clna0d(1) = 'no0d' ; zval0d(1) = -1. ; ENDIF
	277	IF( in1d == 0 ) THEN ; in1d = 1 ; clna1d(1) = 'no1d' ; zval1d(1) = -1. ; ENDIF
	278	IF( in2d == 0 ) THEN ; in2d = 1 ; clna2d(1) = 'no2d' ; zval2d(1) = -1. ; ENDIF
	279	IF( in3d == 0 ) THEN ; in3d = 1 ; clna3d(1) = 'no3d' ; zval3d(1) = -1. ; ENDIF
	280	! update the file header before closing it
[611]	281	WRITE( idrst, REC = 1, IOSTAT = ios, ERR = 987 ) &
[588]	282	& irecl8, inx, iny, inz, in0d, in1d, in2d, in3d, irhd, &
[611]	283	& jpni, jpnj, jpnij, narea, jpiglo, jpjglo, &
[588]	284	& nlcit, nlcjt, nldit, nldjt, nleit, nlejt, nimppt, njmppt
	285	IF( (ivnum * (jpvnl + wp)) > irecl8 ) THEN
	286	CALL ctl_stop( TRIM(clinfo), &
	287	& 'Last record size is too big... You could reduce the value of jpvnl' )
	288	ELSE
[611]	289	WRITE( idrst, REC = irhd, IOSTAT = ios, ERR = 987 ) &
[588]	290	& clna0d(1:in0d), zval0d(1:in0d), clna1d(1:in1d), zval1d(1:in1d), &
	291	& clna2d(1:in2d), zval2d(1:in2d), clna3d(1:in3d), zval3d(1:in3d)
	292	ENDIF
[544]	293	ELSE
	294	ios = 0 ! we cannot write in the file
	295	ENDIF
	296	!
	297	CLOSE( idrst, IOSTAT = ios, ERR = 987 )
	298	987 CONTINUE
[550]	299	IF( ios /= 0 ) THEN
	300	WRITE(ctmp1,*) ' iostat = ', ios
	301	CALL ctl_stop( TRIM(clinfo), &
	302	& ' error when updating the header of '//TRIM(iom_file(kiomid)%name), ctmp1 )
	303	ENDIF
[544]	304	!
	305	END SUBROUTINE iom_rstdimg_close
	306
	307
[550]	308	SUBROUTINE iom_rstdimg_g0d( kiomid, kvid, pvar )
[544]	309	!!-----------------------------------------------------------------------
[550]	310	!! * ROUTINE iom_rstdimg_g0d *
[544]	311	!!
	312	!! ** Purpose : read a scalar with RSTDIMG
	313	!!-----------------------------------------------------------------------
	314	INTEGER, INTENT(in ) :: kiomid ! Identifier of the file
	315	INTEGER, INTENT(in ) :: kvid ! variable id
	316	REAL(wp), INTENT( out) :: pvar ! read field
	317	!---------------------------------------------------------------------
	318	!
	319	pvar = iom_file(kiomid)%ofs(kvid) ! warning: trick... we use ofs to store the value
	320	!
[550]	321	END SUBROUTINE iom_rstdimg_g0d
[544]	322
	323
[611]	324	SUBROUTINE iom_rstdimg_rp0d( kiomid, cdvar, kvid, pv_r0d )
[544]	325	!!--------------------------------------------------------------------
	326	!! * SUBROUTINE iom_rstdimg_rstput *
	327	!!
	328	!! ** Purpose : write a scalar with RSTDIMG
	329	!!--------------------------------------------------------------------
	330	INTEGER , INTENT(in) :: kiomid ! Identifier of the file
	331	CHARACTER(len=*) , INTENT(in) :: cdvar ! time axis name
[611]	332	INTEGER , INTENT(in) :: kvid ! variable id
[556]	333	REAL(wp) , INTENT(in) :: pv_r0d ! written 0d field
[544]	334	!
	335	CHARACTER(LEN=100) :: clinfo ! info character
	336	INTEGER :: idvar ! variable id
	337	!---------------------------------------------------------------------
	338	!
[550]	339	clinfo = ' iom_rstdimg_rp0d ~~~ '
[611]	340	IF( kvid <= 0 ) THEN ! new variable
	341	idvar = iom_file(kiomid)%nvars + 1
	342	ELSE ! the variable already exists in the file
	343	idvar = kvid
	344	ENDIF
[544]	345	IF( idvar <= jpmax_vars ) THEN
	346	iom_file(kiomid)%nvars = idvar
	347	iom_file(kiomid)%cn_var(idvar) = TRIM(cdvar)
	348	iom_file(kiomid)%nvid( idvar) = 1 ! useless, Od variables a strored in record 1
	349	iom_file(kiomid)%ndims( idvar) = 0
	350	iom_file(kiomid)%luld( idvar) = .FALSE.
	351	iom_file(kiomid)%scf( idvar) = 1.
	352	iom_file(kiomid)%ofs( idvar) = pv_r0d ! warning: trick... we use ofs to store the value
	353	ELSE
	354	CALL ctl_stop( TRIM(clinfo), 'increase the value of jpmax_vars' )
	355	ENDIF
[550]	356	END SUBROUTINE iom_rstdimg_rp0d
[544]	357
	358
[679]	359	SUBROUTINE iom_rstdimg_g123d( kiomid, kdom , kvid, kx1, kx2, ky1, ky2, &
	360	& pv_r1d, pv_r2d, pv_r3d )
[544]	361	!!-----------------------------------------------------------------------
[550]	362	!! * ROUTINE iom_rstdimg_g123d *
[544]	363	!!
	364	!! ** Purpose : read a 1D/2D/3D variable with RSTDIMG
	365	!!
	366	!! ** Method : read ONE record at each CALL
	367	!!-----------------------------------------------------------------------
	368	INTEGER , INTENT(in ) :: kiomid ! iom identifier of the file
	369	INTEGER , INTENT(in ) :: kdom ! Type of domain to be read
	370	INTEGER , INTENT(in ) :: kvid ! variable id
[679]	371	INTEGER , INTENT(inout) :: kx1, kx2, ky1, ky2 ! subdomain indexes
[544]	372	REAL(wp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case)
	373	REAL(wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case)
	374	REAL(wp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case)
	375
	376	CHARACTER(LEN=100) :: clinfo ! info character
	377	INTEGER :: ios ! IO status
	378	INTEGER :: jk ! loop counter
	379	INTEGER :: idrst ! logical unit of the restart file
	380	!---------------------------------------------------------------------
[550]	381	clinfo = ' iom_rstdimg_g123d ~~~ '
[544]	382	!
[679]	383	IF( kdom == jpdom_data .OR. kdom == jpdom_global ) THEN
	384	CALL ctl_stop( TRIM(clinfo), TRIM(iom_file(kiomid)%cn_var(kvid))//': case not coded for rstdimg files' )
	385	ELSE
[544]	386	!
[679]	387	idrst = iom_file(kiomid)%nfid ! get back the logical unit of the restart file
	388	! modify the subdomain indexes because we cannot directly extract the appropriate subdomaine
	389	IF( kdom == jpdom_local_full ) THEN ; kx1 = 1 ; kx2 = jpi ; ky1 = 1
	390	ELSEIF( kdom == jpdom_local_noextra ) THEN ; kx1 = 1 ; kx2 = nlci ; ky1 = 1
[544]	391	ENDIF
[679]	392	!
[544]	393	IF( PRESENT(pv_r1d) ) THEN ! read 1D variables
[679]	394	READ( idrst, REC = iom_file(kiomid)%nvid(kvid) , IOSTAT = ios, ERR = 987 ) pv_r1d(:)
[544]	395	ELSEIF( PRESENT(pv_r2d) ) THEN ! read 2D variables
[679]	396	READ( idrst, REC = iom_file(kiomid)%nvid(kvid) , IOSTAT = ios, ERR = 987 ) pv_r2d(kx1:kx2, ky1:ky2 )
[544]	397	ELSEIF( PRESENT(pv_r3d) ) THEN ! read 3D variables
	398	DO jk = 1, iom_file(kiomid)%dimsz(3,kvid) ! do loop on each level
[679]	399	READ( idrst, REC = iom_file(kiomid)%nvid(kvid) + jk - 1, IOSTAT = ios, ERR = 987 ) pv_r3d(kx1:kx2, ky1:ky2, jk)
[544]	400	END DO
	401	ENDIF
[679]	402	987 CONTINUE
	403	IF( ios /= 0 ) THEN
	404	WRITE(ctmp1,*) ' iostat = ', ios
	405	CALL ctl_stop( TRIM(clinfo), ' IO error with file '//TRIM(iom_file(kiomid)%name), ctmp1 )
	406	ENDIF
[544]	407	ENDIF
	408	!
[550]	409	END SUBROUTINE iom_rstdimg_g123d
[544]	410
	411
[611]	412	SUBROUTINE iom_rstdimg_rp123d( kiomid, cdvar, kvid, pv_r1d, pv_r2d, pv_r3d )
[544]	413	!!--------------------------------------------------------------------
	414	!! * SUBROUTINE iom_rstdimg_rstput *
	415	!!
	416	!! ** Purpose : write a 2D/3D variable with RSTDIMG
	417	!!--------------------------------------------------------------------
	418	INTEGER , INTENT(in) :: kiomid ! Identifier of the file
	419	CHARACTER(len=*) , INTENT(in) :: cdvar ! time axis name
[611]	420	INTEGER , INTENT(in) :: kvid ! variable id
[2715]	421	REAL(wp), DIMENSION( :), INTENT(in), OPTIONAL :: pv_r1d ! written 1d field
	422	REAL(wp), DIMENSION(: ,: ), INTENT(in), OPTIONAL :: pv_r2d ! written 2d field
	423	REAL(wp), DIMENSION(: ,: ,: ), INTENT(in), OPTIONAL :: pv_r3d ! written 3d field
[544]	424	!
	425	CHARACTER(LEN=100) :: clinfo ! info character
	426	INTEGER :: irecl8 ! reacord length
	427	INTEGER :: ios ! IO status
	428	INTEGER :: idrst ! reacord length
	429	INTEGER :: inx, iny, inz ! x,y,z dimension of the variable
	430	INTEGER :: idvar ! variable id
	431	INTEGER :: istop ! temporary storage of nstop
	432	INTEGER :: irec ! record number
	433	INTEGER :: ix1, ix2, iy1, iy2 ! subdomain indexes
	434	INTEGER :: jk ! loop counter
	435	!---------------------------------------------------------------------
	436	!
[550]	437	clinfo = ' iom_rstdimg_rp123d, file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(cdvar)
[544]	438	istop = nstop ! store the actual value of nstop
	439	irec = iom_file(kiomid)%irec ! get back the record number of the variable
	440	idrst = iom_file(kiomid)%nfid ! get back the logical unit of the restart file
[611]	441	IF( kvid <= 0 ) THEN ! new variable
	442	idvar = iom_file(kiomid)%nvars + 1
	443	ELSE ! the variable already exists in the file
	444	idvar = kvid
	445	ENDIF
[544]	446	IF( idvar > jpmax_vars ) CALL ctl_stop( TRIM(clinfo), 'increase the value of jpmax_vars' )
	447	IF( .NOT. PRESENT(pv_r1d) ) THEN
	448	! find which part of data must be written
	449	READ( idrst, REC = 1, IOSTAT = ios, ERR = 987 ) irecl8, inx, iny, inz
	450	IF( inx == (nlei - nldi + 1) .AND. iny == (nlej - nldj + 1) ) THEN
	451	ix1 = nldi ; ix2 = nlei ; iy1 = nldj ; iy2 = nlej
	452	ELSEIF( inx == nlci .AND. iny == nlcj ) THEN
	453	ix1 = 1 ; ix2 = nlci ; iy1 = 1 ; iy2 = nlcj
	454	ELSEIF( inx == jpi .AND. iny == jpj ) THEN
	455	ix1 = 1 ; ix2 = jpi ; iy1 = 1 ; iy2 = jpj
	456	ELSE
	457	CALL ctl_stop( clinfo, 'should have been an impossible case...' )
	458	ENDIF
	459	ENDIF
	460	IF( istop == nstop ) THEN
	461	! write the data
	462	IF( PRESENT(pv_r1d) ) THEN ! 1D variable
	463	WRITE( idrst, REC = irec , IOSTAT = ios, ERR = 987 ) pv_r1d(:)
	464	ELSEIF( PRESENT(pv_r2d) ) THEN ! 2D variable
	465	WRITE( idrst, REC = irec , IOSTAT = ios, ERR = 987 ) pv_r2d(ix1:ix2, iy1:iy2 )
	466	ELSEIF( PRESENT(pv_r3d) ) THEN ! 3D variable
	467	DO jk = 1, jpk ! do loop on each level
	468	WRITE( idrst, REC = irec + jk - 1, IOSTAT = ios, ERR = 987 ) pv_r3d(ix1:ix2, iy1:iy2, jk)
	469	END DO
	470	ENDIF
	471	! fill the file informations
	472	iom_file(kiomid)%nvars = idvar
	473	IF( PRESENT(pv_r1d) ) THEN
	474	iom_file(kiomid)%irec = irec + 1
	475	iom_file(kiomid)%ndims( idvar) = 1
[550]	476	iom_file(kiomid)%dimsz(1 , idvar) = inz
[544]	477	ELSEIF( PRESENT(pv_r2d) ) THEN
	478	iom_file(kiomid)%irec = irec + 1
	479	iom_file(kiomid)%ndims( idvar) = 2
	480	iom_file(kiomid)%dimsz(1:2, idvar) = (/ inx, iny /)
	481	ELSEIF( PRESENT(pv_r3d) ) THEN
	482	iom_file(kiomid)%irec = irec + inz
	483	iom_file(kiomid)%ndims( idvar) = 3
	484	iom_file(kiomid)%dimsz(1:3, idvar) = (/ inx, iny, inz /)
	485	ENDIF
	486	iom_file(kiomid)%cn_var(idvar) = TRIM(cdvar)
	487	iom_file(kiomid)%nvid( idvar) = irec
	488	iom_file(kiomid)%luld( idvar) = .FALSE.
	489	iom_file(kiomid)%scf( idvar) = 1.
	490	iom_file(kiomid)%ofs( idvar) = 0.
	491	ENDIF
	492	987 CONTINUE
[550]	493	IF( ios /= 0 ) THEN
	494	WRITE(ctmp1,*) ' iostat = ', ios
	495	CALL ctl_stop( TRIM(clinfo), ' IO error with file '//TRIM(iom_file(kiomid)%name), ctmp1 )
	496	ELSE
	497	IF(lwp) WRITE(numout,*) TRIM(clinfo)//' written ok'
[544]	498	ENDIF
	499	!
[550]	500	END SUBROUTINE iom_rstdimg_rp123d
[544]	501
	502
	503	!!======================================================================
	504	END MODULE iom_rstdimg

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

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

Context Navigation

source: branches/UKMO/r6232_tracer_advection/NEMOGCM/NEMO/OPA_SRC/IOM/iom_rstdimg.F90 @ 9295

Download in other formats: