Context Navigation

module_generic.f90 @ 2329

Last change on this file since 2329 was 2328, checked in by lfita, 6 years ago

Moving:

`zones_homogenization' from 'module_scientific' to 'module_geeric'

File size: 15.5 KB

Rev	Line
[715]	1	MODULE module_generic
	2	! Module with generic functions
[1608]	3
	4	!!!!!!! Subroutines/Functions
[1655]	5	! freeunit: provides the number of a free unit in which open a file
	6	! GetInNamelist: Subroutine to get a paramter from a namelistfile
[1612]	7	! index_list_coordsI: Function to provide the index of a given coordinate within a list of integer coordinates
[1615]	8	! Index1DArrayI: Function to provide the first index of a given value inside a 1D integer array
[1313]	9	! Index1DArrayR: Function to provide the first index of a given value inside a 1D real array
[1608]	10	! Index1DArrayR_K: Function to provide the first index of a given value inside a 1D real(r_k) array
[1313]	11	! Index2DArrayR: Function to provide the first index of a given value inside a 2D real array
[1653]	12	! Index2DArrayR_K: Function to provide the first index of a given value inside a 2D real(r_k) array
[1660]	13	! Nvalues_2DArrayI: Number of different values of a 2D integer array
[1619]	14	! mat2DPosition: Function to provide the i, j indices of a given value inside a 2D matrix
[2235]	15	! numberTimes: Function to provide the number of times that a given set of characters happen within a string
[1608]	16	! RangeI: Function to provide a range of d1 values from 'iniv' to 'endv', of integer values in a vector
	17	! RangeR: Function to provide a range of d1 values from 'iniv' to 'endv', of real values in a vector
	18	! RangeR_K: Function to provide a range of d1 from 'iniv' to 'endv', of real(r_k) values in a vector
[1655]	19	! stoprun: Subroutine to stop running and print a message
[2328]	20	! zones_homogenization: Subroutine to homogenize 2D contiguous zones, zones might be contiguous, but
	21	! with different number assigned !
[715]	22
[1608]	23	USE module_definitions
[1655]	24	USE module_basic
[1184]	25
[715]	26	CONTAINS
	27
[1660]	28	SUBROUTINE Nvalues_2DArrayI(dx, dy, dxy, mat2DI, Nvals, vals)
	29	! Subroutine to give the number of different values of a 2D integer array
	30
	31	IMPLICIT NONE
	32
	33	INTEGER, INTENT(in) :: dx, dy, dxy
	34	INTEGER, DIMENSION(dx,dy), INTENT(in) :: mat2DI
	35	INTEGER, INTENT(out) :: Nvals
	36	INTEGER, DIMENSION(dxy), INTENT(out) :: vals
	37
	38	! Local
	39	INTEGER :: i, j, ij
	40
	41	!!!!!!! Variables
	42	! dx, dy: size of the 2D space
	43	! mat2DI: 2D integer matrix
	44	! Nvals: number of different values
	45	! vals: vector with the different values
	46
	47	fname = 'Nvalues_2DArrayI'
	48
	49	vals = 0
	50
	51	Nvals = 1
	52	vals(1) = mat2DI(1,1)
	53	DO i=1,dx
	54	DO j=1,dy
	55	IF (Index1DArrayI(vals, Nvals, mat2DI(i,j)) == -1) THEN
	56	Nvals = Nvals + 1
	57	vals(Nvals) = mat2DI(i,j)
	58	END IF
	59	END DO
	60	END DO
	61
	62	RETURN
	63
	64	END SUBROUTINE Nvalues_2DArrayI
	65
[1612]	66	INTEGER FUNCTION index_list_coordsI(Ncoords, coords, icoord)
	67	! Function to provide the index of a given coordinate within a list of integer coordinates
	68
	69	IMPLICIT NONE
	70
	71	INTEGER, INTENT(in) :: Ncoords
	72	INTEGER, DIMENSION(Ncoords,2), INTENT(in) :: coords
	73	INTEGER, DIMENSION(2), INTENT(in) :: icoord
	74
	75	! Local
	76	INTEGER, DIMENSION(Ncoords) :: dist
	77	INTEGER :: i,mindist
	78	INTEGER, DIMENSION(1) :: iloc
	79
	80	!!!!!!! Variables
	81	! Ncoords: number of coordinates in the list
	82	! coords: list of coordinates
	83	! icoord: coordinate to find
	84
	85	fname = 'index_list_coordsI'
	86
	87	dist = (coords(:,1)-icoord(1))2+(coords(:,2)-icoord(2))2
	88
	89	IF (ANY(dist == 0)) THEN
	90	iloc = MINLOC(dist)
	91	index_list_coordsI = iloc(1)
	92	ELSE
	93	index_list_coordsI = -1
	94	END IF
	95
	96	END FUNCTION index_list_coordsI
	97
[1615]	98	INTEGER FUNCTION Index1DArrayI(array1D, d1, val)
	99	! Function to provide the first index of a given value inside a 1D integer array
	100
	101	IMPLICIT NONE
	102
	103	INTEGER, INTENT(in) :: d1
	104	INTEGER, INTENT(in) :: val
	105	INTEGER, DIMENSION(d1), INTENT(in) :: array1D
	106
	107	! Local
	108	INTEGER :: i
	109
	110	fname = 'Index1DArrayI'
	111
	112	Index1DArrayI = -1
	113
	114	DO i=1,d1
	115	IF (array1d(i) == val) THEN
	116	Index1DArrayI = i
	117	EXIT
	118	END IF
	119	END DO
	120
	121	END FUNCTION Index1DArrayI
	122
[764]	123	INTEGER FUNCTION Index1DArrayR(array1D, d1, val)
	124	! Function to provide the first index of a given value inside a 1D real array
	125
	126	IMPLICIT NONE
	127
	128	INTEGER, INTENT(in) :: d1
[1653]	129	REAL, INTENT(in) :: val
	130	REAL, DIMENSION(d1), INTENT(in) :: array1D
[764]	131
	132	! Local
	133	INTEGER :: i
	134
	135	fname = 'Index1DArrayR'
	136
	137	Index1DArrayR = -1
	138
	139	DO i=1,d1
	140	IF (array1d(i) == val) THEN
	141	Index1DArrayR = i
	142	EXIT
	143	END IF
	144	END DO
	145
	146	END FUNCTION Index1DArrayR
	147
[1608]	148	INTEGER FUNCTION Index1DArrayR_K(array1D, d1, val)
	149	! Function to provide the first index of a given value inside a 1D real(r_k) array
	150
	151	IMPLICIT NONE
	152
	153	INTEGER, INTENT(in) :: d1
	154	REAL(r_k), INTENT(in) :: val
	155	REAL(r_k), DIMENSION(d1), INTENT(in) :: array1D
	156
	157	! Local
	158	INTEGER :: i
	159
	160	fname = 'Index1DArrayR_K'
	161
	162	Index1DArrayR_K = -1
	163
	164	DO i=1,d1
	165	IF (array1d(i) == val) THEN
	166	Index1DArrayR_K = i
	167	EXIT
	168	END IF
	169	END DO
	170
	171	END FUNCTION Index1DArrayR_K
	172
[715]	173	FUNCTION Index2DArrayR(array2D, d1, d2, val)
	174	! Function to provide the first index of a given value inside a 2D real array
	175
	176	IMPLICIT NONE
	177
	178	INTEGER, INTENT(in) :: d1, d2
[1653]	179	REAL, INTENT(in) :: val
	180	REAL, DIMENSION(d1,d2), INTENT(in) :: array2D
[715]	181	INTEGER, DIMENSION(2) :: Index2DArrayR
	182
	183	! Local
	184	INTEGER :: i, j
	185
	186	fname = 'Index2DArrayR'
	187
	188	Index2DArrayR = -1
	189
	190	DO i=1,d1
	191	DO j=1,d2
	192	IF (array2d(i,j) == val) THEN
	193	Index2DArrayR(1) = i
	194	Index2DArrayR(2) = j
	195	EXIT
	196	END IF
	197	END DO
	198	END DO
	199
	200	END FUNCTION Index2DArrayR
	201
[1653]	202	FUNCTION Index2DArrayR_K(array2D, d1, d2, val)
	203	! Function to provide the first index of a given value inside a 2D real array
	204
	205	IMPLICIT NONE
	206
	207	INTEGER, INTENT(in) :: d1, d2
	208	REAL(r_k), INTENT(in) :: val
	209	REAL(r_k), DIMENSION(d1,d2), INTENT(in) :: array2D
	210	INTEGER, DIMENSION(2) :: Index2DArrayR_K
	211
	212	! Local
	213	INTEGER :: i, j
	214
	215	fname = 'Index2DArrayR_K'
	216
	217	Index2DArrayR_K = -1
	218
	219	DO i=1,d1
	220	DO j=1,d2
	221	IF (array2d(i,j) == val) THEN
	222	Index2DArrayR_K(1) = i
	223	Index2DArrayR_K(2) = j
	224	EXIT
	225	END IF
	226	END DO
	227	END DO
	228
	229	END FUNCTION Index2DArrayR_K
	230
[2235]	231	INTEGER FUNCTION numberTimes(String, charv)
	232	! Function to provide the number of times that a given set of characters happen within a string
	233
	234	IMPLICIT NONE
	235
	236	CHARACTER(LEN=*), INTENT(IN) :: String, charv
	237
	238	! Local
	239	INTEGER :: i, Lstring, Lcharv
	240
	241	numberTimes = 0
	242
	243	Lstring = LEN_TRIM(String)
	244	Lcharv = LEN_TRIM(charv)
	245
	246	DO i=1,Lstring - Lcharv
	247	IF (String(i:i+Lcharv-1) == TRIM(charv)) numberTimes = numberTimes + 1
	248	END DO
	249
	250	END FUNCTION numberTimes
	251
	252
[1608]	253	FUNCTION RangeI(d1, iniv, endv)
	254	! Function to provide a range of d1 values from 'iniv' to 'endv', of integer values in a vector
	255
	256	IMPLICIT NONE
	257
	258	INTEGER, INTENT(in) :: d1, iniv, endv
	259	INTEGER, DIMENSION(d1) :: RangeI
	260
	261	! Local
	262	INTEGER :: i, intv
	263
	264	fname = 'RangeI'
	265
	266	intv = (endv - iniv) / (d1*1 - 1)
	267
	268	RangeI(1) = iniv
	269	DO i=2,d1
	270	RangeI(i) = RangeI(i-1) + intv
	271	END DO
	272
	273	END FUNCTION RangeI
	274
	275	FUNCTION RangeR(d1, iniv, endv)
	276	! Function to provide a range of d1 from 'iniv' to 'endv', of real values in a vector
	277
	278	IMPLICIT NONE
	279
	280	INTEGER, INTENT(in) :: d1
	281	REAL, INTENT(in) :: iniv, endv
	282	REAL, DIMENSION(d1) :: RangeR
	283
	284	! Local
	285	INTEGER :: i
	286	REAL :: intv
	287
	288	fname = 'RangeR'
	289
	290	intv = (endv - iniv) / (d1*1. - 1.)
	291
	292	RangeR(1) = iniv
	293	DO i=2,d1
	294	RangeR(i) = RangeR(i-1) + intv
	295	END DO
	296
	297	END FUNCTION RangeR
	298
	299	FUNCTION RangeR_K(d1, iniv, endv)
	300	! Function to provide a range of d1 from 'iniv' to 'endv', of real(r_k) values in a vector
	301
	302	IMPLICIT NONE
	303
	304	INTEGER, INTENT(in) :: d1
	305	REAL(r_k), INTENT(in) :: iniv, endv
	306	REAL(r_k), DIMENSION(d1) :: RangeR_K
	307
	308	! Local
	309	INTEGER :: i
	310	REAL(r_k) :: intv
	311
	312	fname = 'RangeR_K'
	313
	314	intv = (endv - iniv) / (d1*oneRK-oneRK)
	315
	316	RangeR_K(1) = iniv
	317	DO i=2,d1
	318	RangeR_K(i) = RangeR_K(i-1) + intv
	319	END DO
	320
	321	END FUNCTION RangeR_K
	322
[1655]	323	INTEGER FUNCTION freeunit()
	324	! provides the number of a free unit in which open a file
[1608]	325
[1619]	326	IMPLICIT NONE
	327
[1655]	328	LOGICAL :: is_used
[1619]	329
[1655]	330	is_used = .true.
	331	DO freeunit=10,100
[1660]	332	INQUIRE(unit=freeunit, opened=is_used)
[1655]	333	IF (.not. is_used) EXIT
	334	END DO
	335
	336	RETURN
	337
	338	END FUNCTION freeunit
	339
	340	SUBROUTINE GetInNamelist(namelistfile, param, kindparam, Ival, Rval, Lval, Sval)
	341	! Subroutine to get a paramter from a namelistfile
	342
	343	IMPLICIT NONE
	344
	345	CHARACTER(LEN=*), INTENT(IN) :: namelistfile, param
	346	CHARACTER(LEN=1), INTENT(IN) :: kindparam
	347	INTEGER, OPTIONAL, INTENT(OUT) :: Ival
	348	REAL, OPTIONAL, INTENT(OUT) :: Rval
	349	LOGICAL, OPTIONAL, INTENT(OUT) :: Lval
	350	CHARACTER(LEN=200), OPTIONAL, INTENT(OUT) :: Sval
	351
	352	! Local
	353	INTEGER :: i, funit, ios
	354	INTEGER :: Lparam, posparam
	355	LOGICAL :: is_used
	356	CHARACTER(LEN=1000) :: line, message
	357	CHARACTER(LEN=200), DIMENSION(2) :: lvals
	358	CHARACTER(LEN=200) :: pval
	359
	360	!!!!!!! Variables
	361	! namelistfile: name of the namelist file
	362	! param: parameter to get
	363	! paramkind: kind of the parameter (I: Integer, L: boolean, R: Real, S: String)
	364
	365	fname = 'GetInNamelist'
	366
	367	! Reading dimensions file and defining dimensions
	368	is_used = .true.
	369	DO funit=10,100
	370	INQUIRE(unit=funit, opened=is_used)
	371	IF (.not. is_used) EXIT
	372	END DO
	373
	374	OPEN(funit, FILE=TRIM(namelistfile), STATUS='old', FORM='formatted', IOSTAT=ios)
	375	IF ( ios /= 0 ) CALL stoprun(message, fname)
	376
	377	Lparam = LEN_TRIM(param)
	378
	379	DO i=1,10000
	380	READ(funit,"(A200)",END=100)line
	381	posparam = INDEX(TRIM(line), TRIM(param))
	382	IF (posparam /= 0) EXIT
	383
	384	END DO
	385	100 CONTINUE
	386
	387	IF (posparam == 0) THEN
	388	message = "namelist '" // TRIM(namelistfile) // "' does not have parameter '" // TRIM(param) // &
	389	"' !!"
	390	CALL stoprun(message, fname)
	391	END IF
	392
	393	CLOSE(UNIT=funit)
	394
	395	CALL split(line, '=', 2, lvals)
	396	IF (kindparam /= 'S') THEN
	397	CALL RemoveNonNum(lvals(2), pval)
	398	END IF
	399
	400	! L. Fita, LMD. October 2015
	401	! Up to now, only getting scalar values
	402	kparam: SELECT CASE (kindparam)
	403	CASE ('I')
	404	Ival = StoI(pval)
	405	! PRINT *,TRIM(param),'= ', Ival
	406	CASE ('L')
	407	Lval = StoL(pval)
	408	! PRINT *,TRIM(param),'= ', Lval
	409	CASE ('R')
	410	Rval = StoR(pval)
	411	! PRINT *,TRIM(param),'= ', Rval
	412	CASE ('S')
	413	Sval = lvals(2)
	414
	415	CASE DEFAULT
	416	message = "type of parameter '" // kindparam // "' not ready !!"
	417	CALL stoprun(message, fname)
	418
	419	END SELECT kparam
	420
	421	END SUBROUTINE GetInNamelist
	422
	423	SUBROUTINE stoprun(msg, fname)
	424	! Subroutine to stop running and print a message
	425
	426	IMPLICIT NONE
	427
	428	CHARACTER(LEN=*), INTENT(IN) :: fname
	429	CHARACTER(LEN=*), INTENT(IN) :: msg
	430
	431	! local
	432	CHARACTER(LEN=50) :: errmsg, warnmsg
	433
	434	errmsg = 'ERROR -- error -- ERROR -- error'
	435
	436	PRINT *, TRIM(errmsg)
	437	PRINT *, ' ' // TRIM(fname) // ': ' // TRIM(msg)
[1683]	438	STOP
[1655]	439
	440	END SUBROUTINE stoprun
	441
[2328]	442	SUBROUTINE zones_homogenization(dx, dy, inzones, outzones)
	443	! Subroutine to homogenize 2D contiguous zones, zones might be contiguous, but with different number assigned !
	444	! Here we have a 2D matrix of integers, with contiguous integer filled zones, zero outside any zone
	445	! It might be, that within the same zone, might be lines which do not share the same integer
	446	! 0 0 0 0 0 0 0 0 0 0
	447	! 0 1 1 0 0 0 1 1 0 0
	448	! 0 2 0 0 1 == > 0 1 0 0 2
	449	! 0 1 1 0 0 0 1 1 0 0
	450
	451	IMPLICIT NONE
	452
	453	INTEGER, INTENT(in) :: dx, dy
	454	INTEGER, DIMENSION(dx,dy), INTENT(in) :: inzones
	455	INTEGER, DIMENSION(dx,dy), INTENT(out) :: outzones
	456
	457	! Local
	458	INTEGER :: i,j,k
	459	INTEGER :: Nmaxzones, TOTzones
	460	LOGICAL :: assigned
	461	INTEGER, DIMENSION(dy) :: prevline
	462	INTEGER, DIMENSION(dx) :: Nyzones
	463	INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: zones
	464
	465	!!!!!!! Variables
	466	! dx, dy: Shape of the 2D space
	467	! inzones: zones to homogenize
	468	! outzones: zones homogenized
	469
	470	fname = 'zones_homogenization'
	471
	472	! Maximum possible number of zones
	473	Nmaxzones = INT((dx/2)*(dy/2))
	474
	475	! Matrix with [i,j,Nzone,izone/ezone]
	476	IF (ALLOCATED(zones)) DEALLOCATE(zones)
	477	ALLOCATE(zones(dx,Nmaxzones,3))
	478
	479	zones = 0
	480	Nyzones = 0
	481	! Getting beginning/end of y-bands
	482	DO i=1, dx
	483	k = 0
	484	j = 1
	485	IF (inzones(i,j) /= 0) THEN
	486	k = k + 1
	487	zones(i,k,1) = j
	488	zones(i,k,3) = k
	489	END IF
	490	DO j=2, dy
	491	IF ( (inzones(i,j) /= 0) .AND. (inzones(i,j-1) == 0)) THEN
	492	k = k+1
	493	zones(i,k,1) = j
	494	zones(i,k,3) = k
	495	ELSE IF ( (inzones(i,j-1) /= 0) .AND. (inzones(i,j) == 0)) THEN
	496	zones(i,k,2) = j-1
	497	zones(i,k,3) = k
	498	END IF
	499	END DO
	500	IF (k > 0) THEN
	501	IF (zones(i,k,2) == 0) zones(i,k,2) = dy
	502	END IF
	503	Nyzones(i) = k
	504	END DO
	505
	506	! Homogenizing contigous zones
	507	outzones = 0
	508	TOTzones = 0
	509	i = 1
	510	DO k = 1, Nyzones(i)
	511	TOTzones = TOTzones + 1
	512	DO j=zones(i,k,1), zones(i,k,2)
	513	outzones(i,j) = TOTzones
	514	END DO
	515	END DO
	516
	517	DO i=2, dx
	518	prevline = outzones(i-1,:)
	519	DO k = 1, Nyzones(i)
	520	assigned = .FALSE.
	521	DO j=zones(i,k,1), zones(i,k,2)
	522	IF (prevline(j) /= 0) THEN
	523	outzones(i,zones(i,k,1):zones(i,k,2)) = prevline(j)
	524	assigned = .TRUE.
	525	EXIT
	526	END IF
	527	END DO
	528	IF (.NOT.assigned) THEN
	529	TOTzones = TOTzones + 1
	530	DO j=zones(i,k,1), zones(i,k,2)
	531	outzones(i,j) = TOTzones
	532	END DO
	533	END IF
	534	END DO
	535	END DO
	536
	537	IF (ALLOCATED(zones)) DEALLOCATE(zones)
	538
	539	END SUBROUTINE zones_homogenization
	540
[715]	541	END MODULE module_generic

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

Download in other formats:

Original Format