aux_proc.f90

   1
   2    MODULE Auxiliar_Procedures
   3
   4      INTEGER, SAVE :: AISO  !AISO=0, Anisotropic EZZ and ESUM
   5      INTEGER, SAVE :: MTYPE !MTYPE: 1-> ZBI, 2-> WZI, 3-> WZA
   6
   7    CONTAINS
   8
   9     SUBROUTINE Param_Var(Ind_Par,Dep_Par,Step,Relation)
  10     IMPLICIT NONE
  11
  12      REAL, INTENT(INOUT)              :: Ind_Par
  13      REAL, OPTIONAL, INTENT(INOUT)    :: Dep_Par
  14      REAL, INTENT(IN)                 :: Step
  15      CHARACTER (LEN = * ), INTENT(IN) :: Relation
  16
  17
  18      SELECT CASE (TRIM(Relation))
  19
  20        CASE('Single')
  21
  22                Ind_Par = Ind_Par + Step
  23        CASE('Ratio')
  24
  25                IF(.NOT. PRESENT(Dep_Par) ) THEN
  26                        write(6,*)"Box_Size error. Optional argument Dep_Par Needed!"
  27                        STOP
  28                END IF
  29                Dep_Par   = Dep_Par/Ind_Par * (Ind_Par+Step)
  30                Ind_Par = Ind_Par + Step
  31
  32        CASE('Both')
  33
  34                IF(.NOT. PRESENT(Dep_Par) ) THEN
  35                        write(6,*)"Box_Size error. Optional argument Dep_Par Needed!"
  36                        STOP
  37                END IF
  38                Dep_Par = Dep_Par + Step
  39                Ind_Par = Ind_Par + Step
  40
  41       END SELECT
  42
  43       RETURN
  44
  45      END SUBROUTINE Param_Var
  46
  47
  48 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  49 !             Integration: Simpson's method (version REAL)             !
  50 !                          NX mus be even                              !
  51 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  52
  53       REAL FUNCTION RSIMPSON(F,XINC,NX)
  54       IMPLICIT NONE
  55
  56 !!!!! variables 'dummy' y variables internas !!!!!!!!!!!!!!!!!!!!!!!!!!!
  57
  58       INTEGER      NX,I
  59       REAL         F(0:NX),XINC
  60
  61       RSIMPSON = 0.E0
  62       DO I = 1,NX-1,2
  63          RSIMPSON = RSIMPSON+F(I)
  64       END DO
  65
  66       RSIMPSON = 2.E0*RSIMPSON
  67
  68       DO I = 2,NX-2,2
  69          RSIMPSON = RSIMPSON+F(I)
  70       END DO
  71
  72       RSIMPSON = 2.E0*RSIMPSON+F(0)+F(NX)
  73       RSIMPSON = XINC*RSIMPSON/3.E0
  74
  75       RETURN
  76       END FUNCTION RSIMPSON
  77
  78
  79 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  80 !                     Kronecker's delta                                !
  81 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  82
  83       INTEGER FUNCTION IDELTA(I,J)
  84       IMPLICIT NONE
  85
  86 !!!!! 'dummy' and local variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  87
  88       INTEGER      I,J
  89
  90       IDELTA = 0
  91       IF (I.EQ.J) THEN
  92          IDELTA = 1
  93       END IF
  94       RETURN
  95       END FUNCTION IDELTA
  96
  97 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  98
  99 ! Internal subroutine - checks error status after each netcdf, prints out text message each time
 100 ! an error code is returned.
 101       SUBROUTINE check(status)
 102          USE NETCDF, ONLY: nf90_noerr, nf90_strerror
 103         integer, intent ( in) :: status
 104
 105         if(status /= nf90_noerr) then
 106           print *, trim(nf90_strerror(status))
 107         end if
 108       END SUBROUTINE check
 109
 110 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 111 !!                                                                            !!
 112 !! Subrutina para cambiar el nombre de un archivo existente y asi evitar      !!
 113 !! sobrescribirlo.                                                            !!
 114 !!                                                                            !!
 115 !! ARCH: cadena con el nombre de archivo original.                            !!
 116 !! Mira la longitud de la variable por si admite un contador de cuatro        !!
 117 !! digitos "_XXX". Si lo admite le añade al nombre de archivo ese contador.   !!
 118 !! Si no lo admite sustrae un caracter y le añade un contador simple "X".     !!
 119 !!                                                                            !!
 120 !! Ver: 1.0 Date: 17/04/03                                                    !!
 121 !!                                                                            !!
 122 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 123
 124       SUBROUTINE OPEN_OVER(ARCH)
 125       IMPLICIT NONE
 126
 127        CHARACTER (LEN=*) :: ARCH
 128        CHARACTER (LEN=120) :: ARCH_TMP
 129        LOGICAL :: EX_FILE
 130        INTEGER :: I
 131
 132        INQUIRE(FILE=TRIM(ARCH),EXIST=EX_FILE)
 133        IF (.NOT.EX_FILE) RETURN
 134
 135        IF(LEN(ARCH).LT.(LEN_TRIM(ARCH)+4)) THEN
 136                I=1
 137                DO WHILE (.TRUE.)
 138
 139                 WRITE(ARCH_TMP,'(A,I1)')ARCH(1:LEN(ARCH)-1),I
 140                 INQUIRE(FILE=TRIM(ARCH_TMP),EXIST=EX_FILE)
 141                 IF (.NOT.EX_FILE) THEN
 142                  ARCH=TRIM(ARCH_TMP)
 143                  WRITE(0,*)"Error. Trying to overwrite a file"
 144                  WRITE(0,'(T5,A,A)')"FILE NAME CHANGED TO: ",TRIM(ARCH)
 145                  EXIT
 146                 ELSE
 147                  I=I+1
 148                 ENDIF
 149
 150                END DO
 151         END IF
 152
 153        I=1
 154        DO WHILE (.TRUE.)
 155
 156         WRITE(ARCH_TMP,'(A,"_",I3.3)')TRIM(ARCH),I
 157         INQUIRE(FILE=TRIM(ARCH_TMP),EXIST=EX_FILE)
 158         IF (.NOT.EX_FILE) THEN
 159                 ARCH=TRIM(ARCH_TMP)
 160                 WRITE(0,*)"Error. Trying to overwrite a file"
 161                 WRITE(0,'(T5,A,A)')"FILE NAME CHANGED TO: ",TRIM(ARCH)
 162                 EXIT
 163         ELSE
 164                 I=I+1
 165         ENDIF
 166
 167        END DO
 168
 169        RETURN
 170
 171        END SUBROUTINE OPEN_OVER
 172
 173     END MODULE Auxiliar_Procedures