MODULE module_generic ! Module with generic functions !!!!!!! Subroutines/Functions ! freeunit: provides the number of a free unit in which open a file ! GetInNamelist: Subroutine to get a paramter from a namelistfile ! index_list_coordsI: Function to provide the index of a given coordinate within a list of integer coordinates ! Index1DArrayI: Function to provide the first index of a given value inside a 1D integer array ! Index1DArrayR: Function to provide the first index of a given value inside a 1D real array ! Index1DArrayR_K: Function to provide the first index of a given value inside a 1D real(r_k) array ! Index2DArrayR: Function to provide the first index of a given value inside a 2D real array ! Index2DArrayR_K: Function to provide the first index of a given value inside a 2D real(r_k) array ! Nvalues_2DArrayI: Number of different values of a 2D integer array ! mat2DPosition: Function to provide the i, j indices of a given value inside a 2D matrix ! RangeI: Function to provide a range of d1 values from 'iniv' to 'endv', of integer values in a vector ! RangeR: Function to provide a range of d1 values from 'iniv' to 'endv', of real values in a vector ! RangeR_K: Function to provide a range of d1 from 'iniv' to 'endv', of real(r_k) values in a vector ! stoprun: Subroutine to stop running and print a message USE module_definitions USE module_basic CONTAINS SUBROUTINE Nvalues_2DArrayI(dx, dy, dxy, mat2DI, Nvals, vals) ! Subroutine to give the number of different values of a 2D integer array IMPLICIT NONE INTEGER, INTENT(in) :: dx, dy, dxy INTEGER, DIMENSION(dx,dy), INTENT(in) :: mat2DI INTEGER, INTENT(out) :: Nvals INTEGER, DIMENSION(dxy), INTENT(out) :: vals ! Local INTEGER :: i, j, ij !!!!!!! Variables ! dx, dy: size of the 2D space ! mat2DI: 2D integer matrix ! Nvals: number of different values ! vals: vector with the different values fname = 'Nvalues_2DArrayI' vals = 0 Nvals = 1 vals(1) = mat2DI(1,1) DO i=1,dx DO j=1,dy IF (Index1DArrayI(vals, Nvals, mat2DI(i,j)) == -1) THEN Nvals = Nvals + 1 vals(Nvals) = mat2DI(i,j) END IF END DO END DO RETURN END SUBROUTINE Nvalues_2DArrayI INTEGER FUNCTION index_list_coordsI(Ncoords, coords, icoord) ! Function to provide the index of a given coordinate within a list of integer coordinates IMPLICIT NONE INTEGER, INTENT(in) :: Ncoords INTEGER, DIMENSION(Ncoords,2), INTENT(in) :: coords INTEGER, DIMENSION(2), INTENT(in) :: icoord ! Local INTEGER, DIMENSION(Ncoords) :: dist INTEGER :: i,mindist INTEGER, DIMENSION(1) :: iloc !!!!!!! Variables ! Ncoords: number of coordinates in the list ! coords: list of coordinates ! icoord: coordinate to find fname = 'index_list_coordsI' dist = (coords(:,1)-icoord(1))**2+(coords(:,2)-icoord(2))**2 IF (ANY(dist == 0)) THEN iloc = MINLOC(dist) index_list_coordsI = iloc(1) ELSE index_list_coordsI = -1 END IF END FUNCTION index_list_coordsI INTEGER FUNCTION Index1DArrayI(array1D, d1, val) ! Function to provide the first index of a given value inside a 1D integer array IMPLICIT NONE INTEGER, INTENT(in) :: d1 INTEGER, INTENT(in) :: val INTEGER, DIMENSION(d1), INTENT(in) :: array1D ! Local INTEGER :: i fname = 'Index1DArrayI' Index1DArrayI = -1 DO i=1,d1 IF (array1d(i) == val) THEN Index1DArrayI = i EXIT END IF END DO END FUNCTION Index1DArrayI INTEGER FUNCTION Index1DArrayR(array1D, d1, val) ! Function to provide the first index of a given value inside a 1D real array IMPLICIT NONE INTEGER, INTENT(in) :: d1 REAL, INTENT(in) :: val REAL, DIMENSION(d1), INTENT(in) :: array1D ! Local INTEGER :: i fname = 'Index1DArrayR' Index1DArrayR = -1 DO i=1,d1 IF (array1d(i) == val) THEN Index1DArrayR = i EXIT END IF END DO END FUNCTION Index1DArrayR INTEGER FUNCTION Index1DArrayR_K(array1D, d1, val) ! Function to provide the first index of a given value inside a 1D real(r_k) array IMPLICIT NONE INTEGER, INTENT(in) :: d1 REAL(r_k), INTENT(in) :: val REAL(r_k), DIMENSION(d1), INTENT(in) :: array1D ! Local INTEGER :: i fname = 'Index1DArrayR_K' Index1DArrayR_K = -1 DO i=1,d1 IF (array1d(i) == val) THEN Index1DArrayR_K = i EXIT END IF END DO END FUNCTION Index1DArrayR_K FUNCTION Index2DArrayR(array2D, d1, d2, val) ! Function to provide the first index of a given value inside a 2D real array IMPLICIT NONE INTEGER, INTENT(in) :: d1, d2 REAL, INTENT(in) :: val REAL, DIMENSION(d1,d2), INTENT(in) :: array2D INTEGER, DIMENSION(2) :: Index2DArrayR ! Local INTEGER :: i, j fname = 'Index2DArrayR' Index2DArrayR = -1 DO i=1,d1 DO j=1,d2 IF (array2d(i,j) == val) THEN Index2DArrayR(1) = i Index2DArrayR(2) = j EXIT END IF END DO END DO END FUNCTION Index2DArrayR FUNCTION Index2DArrayR_K(array2D, d1, d2, val) ! Function to provide the first index of a given value inside a 2D real array IMPLICIT NONE INTEGER, INTENT(in) :: d1, d2 REAL(r_k), INTENT(in) :: val REAL(r_k), DIMENSION(d1,d2), INTENT(in) :: array2D INTEGER, DIMENSION(2) :: Index2DArrayR_K ! Local INTEGER :: i, j fname = 'Index2DArrayR_K' Index2DArrayR_K = -1 DO i=1,d1 DO j=1,d2 IF (array2d(i,j) == val) THEN Index2DArrayR_K(1) = i Index2DArrayR_K(2) = j EXIT END IF END DO END DO END FUNCTION Index2DArrayR_K FUNCTION RangeI(d1, iniv, endv) ! Function to provide a range of d1 values from 'iniv' to 'endv', of integer values in a vector IMPLICIT NONE INTEGER, INTENT(in) :: d1, iniv, endv INTEGER, DIMENSION(d1) :: RangeI ! Local INTEGER :: i, intv fname = 'RangeI' intv = (endv - iniv) / (d1*1 - 1) RangeI(1) = iniv DO i=2,d1 RangeI(i) = RangeI(i-1) + intv END DO END FUNCTION RangeI FUNCTION RangeR(d1, iniv, endv) ! Function to provide a range of d1 from 'iniv' to 'endv', of real values in a vector IMPLICIT NONE INTEGER, INTENT(in) :: d1 REAL, INTENT(in) :: iniv, endv REAL, DIMENSION(d1) :: RangeR ! Local INTEGER :: i REAL :: intv fname = 'RangeR' intv = (endv - iniv) / (d1*1. - 1.) RangeR(1) = iniv DO i=2,d1 RangeR(i) = RangeR(i-1) + intv END DO END FUNCTION RangeR FUNCTION RangeR_K(d1, iniv, endv) ! Function to provide a range of d1 from 'iniv' to 'endv', of real(r_k) values in a vector IMPLICIT NONE INTEGER, INTENT(in) :: d1 REAL(r_k), INTENT(in) :: iniv, endv REAL(r_k), DIMENSION(d1) :: RangeR_K ! Local INTEGER :: i REAL(r_k) :: intv fname = 'RangeR_K' intv = (endv - iniv) / (d1*oneRK-oneRK) RangeR_K(1) = iniv DO i=2,d1 RangeR_K(i) = RangeR_K(i-1) + intv END DO END FUNCTION RangeR_K INTEGER FUNCTION freeunit() ! provides the number of a free unit in which open a file IMPLICIT NONE LOGICAL :: is_used is_used = .true. DO freeunit=10,100 INQUIRE(unit=freeunit, opened=is_used) IF (.not. is_used) EXIT END DO RETURN END FUNCTION freeunit SUBROUTINE GetInNamelist(namelistfile, param, kindparam, Ival, Rval, Lval, Sval) ! Subroutine to get a paramter from a namelistfile IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: namelistfile, param CHARACTER(LEN=1), INTENT(IN) :: kindparam INTEGER, OPTIONAL, INTENT(OUT) :: Ival REAL, OPTIONAL, INTENT(OUT) :: Rval LOGICAL, OPTIONAL, INTENT(OUT) :: Lval CHARACTER(LEN=200), OPTIONAL, INTENT(OUT) :: Sval ! Local INTEGER :: i, funit, ios INTEGER :: Lparam, posparam LOGICAL :: is_used CHARACTER(LEN=1000) :: line, message CHARACTER(LEN=200), DIMENSION(2) :: lvals CHARACTER(LEN=200) :: pval !!!!!!! Variables ! namelistfile: name of the namelist file ! param: parameter to get ! paramkind: kind of the parameter (I: Integer, L: boolean, R: Real, S: String) fname = 'GetInNamelist' ! Reading dimensions file and defining dimensions is_used = .true. DO funit=10,100 INQUIRE(unit=funit, opened=is_used) IF (.not. is_used) EXIT END DO OPEN(funit, FILE=TRIM(namelistfile), STATUS='old', FORM='formatted', IOSTAT=ios) IF ( ios /= 0 ) CALL stoprun(message, fname) Lparam = LEN_TRIM(param) DO i=1,10000 READ(funit,"(A200)",END=100)line posparam = INDEX(TRIM(line), TRIM(param)) IF (posparam /= 0) EXIT END DO 100 CONTINUE IF (posparam == 0) THEN message = "namelist '" // TRIM(namelistfile) // "' does not have parameter '" // TRIM(param) // & "' !!" CALL stoprun(message, fname) END IF CLOSE(UNIT=funit) CALL split(line, '=', 2, lvals) IF (kindparam /= 'S') THEN CALL RemoveNonNum(lvals(2), pval) END IF ! L. Fita, LMD. October 2015 ! Up to now, only getting scalar values kparam: SELECT CASE (kindparam) CASE ('I') Ival = StoI(pval) ! PRINT *,TRIM(param),'= ', Ival CASE ('L') Lval = StoL(pval) ! PRINT *,TRIM(param),'= ', Lval CASE ('R') Rval = StoR(pval) ! PRINT *,TRIM(param),'= ', Rval CASE ('S') Sval = lvals(2) CASE DEFAULT message = "type of parameter '" // kindparam // "' not ready !!" CALL stoprun(message, fname) END SELECT kparam END SUBROUTINE GetInNamelist SUBROUTINE stoprun(msg, fname) ! Subroutine to stop running and print a message IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: fname CHARACTER(LEN=*), INTENT(IN) :: msg ! local CHARACTER(LEN=50) :: errmsg, warnmsg errmsg = 'ERROR -- error -- ERROR -- error' PRINT *, TRIM(errmsg) PRINT *, ' ' // TRIM(fname) // ': ' // TRIM(msg) STOP END SUBROUTINE stoprun END MODULE module_generic