Changeset 2724 in lmdz_wrf for trunk

Timestamp:

Oct 16, 2019, 4:11:34 PM (6 years ago)

Author:

lfita

Message:

Adding:

• `fill_matrix2DRK_winmat2D_list1D': Subroutine to fill a 2D RK matrix using a list of 1D indices from another given 2D matrix

File:

• trunk/tools/module_generic.f90 (modified) (3 diffs)

trunk/tools/module_generic.f90

@@ -5 +5 @@
 ! continguos_homogene_zones: Subroutine to look for contiguous zones by looking by continuous grid points
 ! freeunit: provides the number of a free unit in which open a file
+! fill_matrix2DRK_winmat2D_list1D: Subroutine to fill a 2D RK matrix using a list of 1D indices from 
+!   another given 2D matrix
 ! from_coordlist_2DRKmatrix: Subroutine to construct a 2D RK matrix from a list of values accompaigned 
 !   by a list of coordinates to find i,j grid-point coordinates by minimum distance
@@ -21 +23 @@
 ! 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
+! index_samevals1D_RK: Subroutine to search for the indices of the same values between 2 1D RK series 
+!   of values allowing repetitions
+! index_samevals2D_RK: Subroutine to search for the indices of the same values between 2 2D RK series 
+!   of values allowing repetitions
 ! JD: Fucntion to compute the julian date (JD) given a gregorian calendar
 ! Nvalues_2DArrayI: Number of different values of a 2D integer array
@@ -1229 +1235 @@
   END SUBROUTINE rm_values_vecRK
 
+  SUBROUTINE index_samevals1D_RK(d1r, refv, d1v, vals, ii, indices, samevalues)
+  ! Subroutine to search for the indices of the same values between 2 1D RK series of values allowing 
+  !   repetitions
+
+    IMPLICIT NONE
+
+    INTEGER, INTENT(in)                                  :: d1r, d1v
+    REAL(r_k), DIMENSION(d1r), INTENT(in)                :: refv
+    REAL(r_k), DIMENSION(d1v), INTENT(in)                :: vals
+    INTEGER, INTENT(out)                                 :: ii
+    INTEGER, DIMENSION(d1v,2), INTENT(out)               :: indices
+    REAL(r_k), DIMENSION(d1v), INTENT(out)               :: samevalues
+
+! Local
+    INTEGER                                              :: ir, iv, iiv
+
+!!!!!!! Variables
+! d1r: size of the reference data
+! refv: reference values
+! d1v: size of the values
+! vals: values to look in
+! ii: quantity of same values found
+! indices: output
+! samevalues: values where coincidence is found
+
+    fname = 'index_samevals1D_RK'
+
+    indices = 0
+    samevalues = zeroRK
+    ii = 0
+    DO ir=1, d1r
+      DO iv=1, d1v
+        IF (vals(iv) == refv(ir)) THEN
+          ii = ii + 1
+          indices(ii,:) = (/ ir, iv /)
+          samevalues(ii) = refv(ir)
+        END IF
+      END DO
+    END DO
+
+    RETURN
+
+  END SUBROUTINE index_samevals1D_RK
+
+  SUBROUTINE index_samevals2D_RK(d1r, d2r, refv, d1v, d2v, d12v, vals, ii, indices, samevalues)
+  ! Subroutine to search for the indices of the same values between 2 2D RK series of values allowing 
+  !   repetitions
+
+    IMPLICIT NONE
+
+    INTEGER, INTENT(in)                                  :: d1r, d2r, d1v, d2v, d12v
+    REAL(r_k), DIMENSION(d1r,d2r), INTENT(in)            :: refv
+    REAL(r_k), DIMENSION(d1v,d2v), INTENT(in)            :: vals
+    INTEGER, INTENT(out)                                 :: ii
+    INTEGER, DIMENSION(d12v,2,2), INTENT(out)            :: indices
+    REAL(r_k), DIMENSION(d12v), INTENT(out)              :: samevalues
+
+! Local
+    INTEGER                                              :: ir1, ir2, iv1, iv2
+
+!!!!!!! Variables
+! d1r, d2r: size of the reference data
+! refv: reference values
+! d1v, d2v: size of the values
+! vals: values to look in
+! ii: quantity of same values found
+! indices: output
+! samevalues: values where coincidence is found
+
+    fname = 'index_samevals2D_RK'
+
+    indices = 0
+    samevalues = zeroRK
+    ii = 0
+    DO ir1=1, d1r
+      DO ir2=1, d2r
+        DO iv1=1, d1v
+          DO iv2=1, d2v
+            IF (vals(iv1,iv2) == refv(ir1,ir2)) THEN
+              ii = ii + 1
+              indices(ii,1,1) = ir1
+              indices(ii,1,2) = ir2
+              indices(ii,2,1) = iv1
+              indices(ii,2,2) = iv2
+              samevalues(ii) = refv(ir1,ir2)
+            END IF
+          END DO
+        END DO
+      END DO
+    END DO
+
+    RETURN
+
+  END SUBROUTINE index_samevals2D_RK
+
+  SUBROUTINE fill_matrix2DRK_winmat2D_list1D(d1i, d2i, inmatrix, ind, dlist, inlist, olist, missval,  &
+    od, d1o, d2o, omat)
+! Subroutine to fill a 2D RK matrix using a list of 1D indices from another given 2D matrix
+
+    IMPLICIT NONE
+
+    INTEGER, INTENT(in)                                  :: d1i, d2i, ind, dlist, od, d1o, d2o
+    REAL(r_k), DIMENSION(d1i, d2i), INTENT(in)           :: inmatrix
+    INTEGER, DIMENSION(dlist), INTENT(in)                :: inlist, olist
+    REAL(r_k), INTENT(in)                                :: missval
+    REAL(r_k), DIMENSION(d1o, d2o), INTENT(out)          :: omat
+
+! Local
+    INTEGER                                              :: ii, ij, oi, oj, il
+    INTEGER                                              :: isame, osame, irun, orun
+    INTEGER                                              :: ilx, olx
+    CHARACTER(len=3)                                     :: isS, osS
+
+!!!!!!! Variables
+! d1i, d2i: size of the input matrix
+! inmatrix: input matrix with the values to fill the output matrix
+! ind: dimension of the input matrix that the list of indices refer to
+! dlist: number of indices from the list
+! inlist: list of indices from the input matrix
+! olist: list of indices from the output matrix
+! missval: missing value
+! od: dimension of the output matix to which assign the indices of the list
+! d1o, d2o: size of the output matrix
+! omat: output matrix
+
+    fname = 'fill_matrix2DRK_winmat2D_list1D'
+
+    omat = missval
+
+    IF (ind == 1) THEN
+      isame = d2i
+      irun = d1i
+    ELSE
+      isame = d1i
+      irun = d2i
+    END IF
+
+    IF (od == 1) THEN
+      osame = d2o
+      orun = d1o
+    ELSE
+      osame = d1o
+      orun = d2o
+    END IF
+
+    IF (isame /= osame) THEN
+      WRITE(isS,'(I3)')isame
+      WRITE(osS,'(I3)')osame
+      msg = 'Resultant working size from input ' // isS // ' to output ' // osS // ' differ !!'
+      CALL ErrMsg(msg, fname, -1)
+    END IF
+
+    ilx = MAXVAL(inlist)
+    olx = MAXVAL(olist)
+
+    IF (ilx > irun) THEN
+      WRITE(isS,'(I3)')ilx
+      WRITE(osS,'(I3)')irun
+      msg = 'Maximum value in input indices ' // isS // ' larger than assigned dimension ' // osS //  &
+        ' !!'
+      CALL ErrMsg(msg, fname, -1)
+    END IF
+
+    IF (olx > orun) THEN
+      WRITE(isS,'(I3)')olx
+      WRITE(osS,'(I3)')orun
+      msg = 'Maximum value in output indices ' // isS // ' larger than assigned dimension ' // osS // &
+        ' !!'
+      CALL ErrMsg(msg, fname, -1)
+    END IF
+
+    IF (od == 1) THEN
+      IF (ind == 1) THEN
+        DO il=1, dlist
+          omat(olist(il),:) = inmatrix(inlist(il),:)
+        END DO
+      ELSE
+        DO il=1, dlist
+          omat(olist(il),:) = inmatrix(:,inlist(il))
+        END DO
+      END IF
+    ELSE
+      IF (ind == 1) THEN
+        DO il=1, dlist
+          omat(:,olist(il)) = inmatrix(inlist(il),:)
+        END DO
+      ELSE
+        DO il=1, dlist
+          omat(:,olist(il)) = inmatrix(:,inlist(il))
+        END DO
+      END IF
+    END IF
+
+    RETURN
+
+  END SUBROUTINE fill_matrix2DRK_winmat2D_list1D
+
+
 END MODULE module_generic