| 1 | ! |
|---|
| 2 | ! Place here all those small routines that do not fit in orchidee logic yet |
|---|
| 3 | ! |
|---|
| 4 | ! |
|---|
| 5 | !< $HeadURL: svn://forge.ipsl.jussieu.fr/orchidee/branches/ORCHIDEE-MICT/ORCHIDEE/src_global/interpol_help.f90 $ |
|---|
| 6 | !< $Date: 2016-06-17 13:26:43 +0200 (Fri, 17 Jun 2016) $ |
|---|
| 7 | !< $Author: albert.jornet $ |
|---|
| 8 | !< $Revision: 3564 $ |
|---|
| 9 | ! |
|---|
| 10 | ! |
|---|
| 11 | MODULE utils |
|---|
| 12 | |
|---|
| 13 | ! Modules used : |
|---|
| 14 | |
|---|
| 15 | USE netcdf |
|---|
| 16 | USE defprec |
|---|
| 17 | USE ioipsl_para |
|---|
| 18 | |
|---|
| 19 | IMPLICIT NONE |
|---|
| 20 | |
|---|
| 21 | PRIVATE |
|---|
| 22 | PUBLIC nccheck, check_lai_vs_assim, show_values, compare_results |
|---|
| 23 | ! |
|---|
| 24 | INTERFACE show_values |
|---|
| 25 | MODULE PROCEDURE show_values_r_scal, show_values_r1, show_values_r2, show_values_r3, show_values_r4 |
|---|
| 26 | END INTERFACE |
|---|
| 27 | ! |
|---|
| 28 | INTERFACE compare_results |
|---|
| 29 | MODULE PROCEDURE compare_results_r2, compare_results_r3 |
|---|
| 30 | END INTERFACE |
|---|
| 31 | ! |
|---|
| 32 | ! Show_values parameters |
|---|
| 33 | ! |
|---|
| 34 | INTEGER(i_std), PARAMETER :: PX_VAL = 1 ! Gridcell/pixel value |
|---|
| 35 | INTEGER(i_std), PARAMETER :: PFT_VAL = 3 ! PFT |
|---|
| 36 | INTEGER(i_std), PARAMETER :: PROC_VAL = 0 ! Processor |
|---|
| 37 | ! |
|---|
| 38 | CONTAINS |
|---|
| 39 | ! |
|---|
| 40 | !! ================================================================================================================================ |
|---|
| 41 | !! SUBROUTINE : nccheck |
|---|
| 42 | !! |
|---|
| 43 | !>\BRIEF Check for netcdf exit status |
|---|
| 44 | !! |
|---|
| 45 | !! DESCRIPTION : Launch an orchidee error message if status variable contains a netcdf error |
|---|
| 46 | !! |
|---|
| 47 | !! RECENT CHANGE(S) : None |
|---|
| 48 | !! |
|---|
| 49 | !! REFERENCE(S) : None |
|---|
| 50 | !! |
|---|
| 51 | !! FLOWCHART : None |
|---|
| 52 | !! \n |
|---|
| 53 | !_ ================================================================================================================================ |
|---|
| 54 | SUBROUTINE nccheck(status) |
|---|
| 55 | INTEGER(i_std), INTENT (IN) :: status |
|---|
| 56 | CHARACTER(LEN=200) :: mesg |
|---|
| 57 | |
|---|
| 58 | IF(status /= nf90_noerr) THEN |
|---|
| 59 | |
|---|
| 60 | WRITE(numout, *) trim(nf90_strerror(status)) |
|---|
| 61 | CALL ipslerr_p(3, 'nccheck', 'Netcdf error', 'Check out_orchide_XXXX output files', 'for more information') |
|---|
| 62 | END IF |
|---|
| 63 | END SUBROUTINE nccheck |
|---|
| 64 | ! |
|---|
| 65 | !! ================================================================================================================================ |
|---|
| 66 | !! SUBROUTINE : check_lai_vs_assim |
|---|
| 67 | !! |
|---|
| 68 | !>\BRIEF Check consistency between lai and assim_param |
|---|
| 69 | !! |
|---|
| 70 | !! DESCRIPTION : Launch an orchidee error message this 2 variables are not consistent. |
|---|
| 71 | !! This will prevent any kind of error in the condveg module. |
|---|
| 72 | !! |
|---|
| 73 | !! RECENT CHANGE(S) : None |
|---|
| 74 | !! |
|---|
| 75 | !! REFERENCE(S) : None |
|---|
| 76 | !! |
|---|
| 77 | !! FLOWCHART : None |
|---|
| 78 | !! \n |
|---|
| 79 | !_ ================================================================================================================================ |
|---|
| 80 | SUBROUTINE check_lai_vs_assim(kjpindex, lalo, veget_max, lai, vcmax, caller) |
|---|
| 81 | |
|---|
| 82 | USE pft_parameters_var |
|---|
| 83 | |
|---|
| 84 | INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size (unitless) |
|---|
| 85 | REAL(r_std),DIMENSION (kjpindex,2), INTENT (in) :: lalo !! Geographical coordinates |
|---|
| 86 | REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: veget_max !! Maximum vegetation fraction of each PFT inside |
|---|
| 87 | !! the grid box (0-1, unitless) |
|---|
| 88 | REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: vcmax !! min+max+opt temps, vcmax, vjmax |
|---|
| 89 | REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: lai !! Leaf area index (m^2 m^{-2}) |
|---|
| 90 | CHARACTER(LEN=*) :: caller |
|---|
| 91 | |
|---|
| 92 | INTEGER(i_std) :: ji, jv |
|---|
| 93 | CHARACTER(LEN=150) :: printstr, printstr2 !! For temporary uses |
|---|
| 94 | !_ ================================================================================================================================ |
|---|
| 95 | |
|---|
| 96 | DO jv=2, nvm |
|---|
| 97 | DO ji=1,kjpindex |
|---|
| 98 | ! |
|---|
| 99 | IF ( ( veget_max(ji,jv) .GT. min_sechiba ) ) THEN |
|---|
| 100 | |
|---|
| 101 | IF ( (lai(ji,jv) .GT. 0.01) .AND. vcmax(ji,jv) <= 0) THEN |
|---|
| 102 | WRITE(printstr, *) 'check_lai_vs_assim::coordinates lat=', lalo(ji, 1),' long=', lalo(ji, 2), 'PFT=', jv, ",npts=", ji |
|---|
| 103 | WRITE(printstr2, *) 'check_lai_vs_assim:: lai=', lai(ji,jv), ' assim_param=', vcmax(ji,jv) |
|---|
| 104 | CALL ipslerr_p(3, caller//'::check_lai_vs_assim', 'assim_param must be bigger than 0 to be consistent with lai', & |
|---|
| 105 | TRIM(printstr), TRIM(printstr2)) |
|---|
| 106 | ENDIF |
|---|
| 107 | ENDIF |
|---|
| 108 | ENDDO |
|---|
| 109 | ENDDO |
|---|
| 110 | |
|---|
| 111 | END SUBROUTINE check_lai_vs_assim |
|---|
| 112 | ! |
|---|
| 113 | !! ================================================================================================================================ |
|---|
| 114 | !! SUBROUTINE : show_values |
|---|
| 115 | !! |
|---|
| 116 | !>\BRIEF Print values of a specific pixel and pft (if applies) |
|---|
| 117 | !! |
|---|
| 118 | !! DESCRIPTION : Print values of a specific pixel, pft(if applies) and processor. For this purpose, define the PARAMETERS below: |
|---|
| 119 | !! |
|---|
| 120 | !! The use of PX_VAL, PFT_VAL and PROC_VAL determines which values prints for (gridcell, pft and processor) |
|---|
| 121 | !! The rest of the values will be summed to get a unique value |
|---|
| 122 | !! |
|---|
| 123 | !! Those subroutines are meant for developpers to help them trace values |
|---|
| 124 | !! |
|---|
| 125 | !! RECENT CHANGE(S) : None |
|---|
| 126 | !! |
|---|
| 127 | !! REFERENCE(S) : None |
|---|
| 128 | !! |
|---|
| 129 | !! FLOWCHART : None |
|---|
| 130 | !! \n |
|---|
| 131 | !_ ================================================================================================================================ |
|---|
| 132 | SUBROUTINE show_values_r_scal(subrname, varname, var) |
|---|
| 133 | CHARACTER(LEN=*), INTENT(in) :: subrname |
|---|
| 134 | CHARACTER(LEN=*), INTENT(in) :: varname |
|---|
| 135 | REAL(r_std), INTENT(in) :: var |
|---|
| 136 | |
|---|
| 137 | IF (mpi_rank == PROC_VAL) WRITE(numout, *) "show_values_r_scal::"//TRIM(subrname)//"::"//TRIM(varname)//"=", var |
|---|
| 138 | |
|---|
| 139 | END SUBROUTINE show_values_r_scal |
|---|
| 140 | |
|---|
| 141 | SUBROUTINE show_values_r1(subrname, varname, var) |
|---|
| 142 | CHARACTER(LEN=*), INTENT(in) :: subrname |
|---|
| 143 | CHARACTER(LEN=*), INTENT(in) :: varname |
|---|
| 144 | REAL(r_std), DIMENSION(:), INTENT(in) :: var |
|---|
| 145 | |
|---|
| 146 | IF (mpi_rank == PROC_VAL) WRITE(numout, *) "show_values_r1::"//TRIM(subrname)//"::"//TRIM(varname)//"=", var(PX_VAL) |
|---|
| 147 | |
|---|
| 148 | END SUBROUTINE show_values_r1 |
|---|
| 149 | |
|---|
| 150 | SUBROUTINE show_values_r2(subrname, varname, var) |
|---|
| 151 | CHARACTER(LEN=*), INTENT(in) :: subrname |
|---|
| 152 | CHARACTER(LEN=*), INTENT(in) :: varname |
|---|
| 153 | REAL(r_std), DIMENSION(:,:), INTENT(in) :: var |
|---|
| 154 | |
|---|
| 155 | IF (mpi_rank == PROC_VAL) WRITE(numout, *) "show_values_r2::"//TRIM(subrname)//"::"//TRIM(varname)//"=", var(PX_VAL, PFT_VAL) |
|---|
| 156 | |
|---|
| 157 | END SUBROUTINE show_values_r2 |
|---|
| 158 | |
|---|
| 159 | SUBROUTINE show_values_r3(subrname, varname, var, pftind) |
|---|
| 160 | CHARACTER(LEN=*), INTENT(in) :: subrname |
|---|
| 161 | CHARACTER(LEN=*), INTENT(in) :: varname |
|---|
| 162 | REAL(r_std), DIMENSION(:,:,:), INTENT(in) :: var |
|---|
| 163 | INTEGER(i_std), INTENT(in), OPTIONAL :: pftind ! pft index found in the array |
|---|
| 164 | |
|---|
| 165 | IF (.NOT. PRESENT(pftind) .OR. (PRESENT(pftind) .AND. pftind == 2)) THEN |
|---|
| 166 | IF (mpi_rank == PROC_VAL) WRITE(numout, *) "show_values_r3::"//TRIM(subrname)//"::"//TRIM(varname)//"=", var(PX_VAL, PFT_VAL,1) |
|---|
| 167 | ELSE IF ( pftind == 3) THEN |
|---|
| 168 | IF (mpi_rank == PROC_VAL) WRITE(numout, *) "show_values_r3::"//TRIM(subrname)//"::"//TRIM(varname)//"=", var(PX_VAL, 1, PFT_VAL) |
|---|
| 169 | ELSE |
|---|
| 170 | CALL ipslerr_p(3,'show_values_r3','wrong pftind value','Allowed 2 or 3 but found:',pftind) |
|---|
| 171 | ENDIF |
|---|
| 172 | |
|---|
| 173 | END SUBROUTINE show_values_r3 |
|---|
| 174 | |
|---|
| 175 | SUBROUTINE show_values_r4(subrname, varname, var, pftind) |
|---|
| 176 | CHARACTER(LEN=*), INTENT(in) :: subrname |
|---|
| 177 | CHARACTER(LEN=*), INTENT(in) :: varname |
|---|
| 178 | REAL(r_std), DIMENSION(:,:,:,:), INTENT(in) :: var |
|---|
| 179 | INTEGER(i_std), INTENT(in), OPTIONAL :: pftind ! pft index found in the array |
|---|
| 180 | |
|---|
| 181 | IF (.NOT. PRESENT(pftind) .OR. (PRESENT(pftind) .AND. pftind == 2)) THEN |
|---|
| 182 | IF (mpi_rank == PROC_VAL) WRITE(numout, *) "show_values_r4::"//TRIM(subrname)//"::"//TRIM(varname)//"=", SUM(SUM(var(PX_VAL,PFT_VAL,:,:),DIM=2)) |
|---|
| 183 | ELSE IF ( pftind == 3 ) THEN |
|---|
| 184 | IF (mpi_rank == PROC_VAL) WRITE(numout, *) "show_values_r4::"//TRIM(subrname)//"::"//TRIM(varname)//"=", SUM(SUM(var(PX_VAL,:,PFT_VAL,:),DIM=2)) |
|---|
| 185 | ELSE IF ( pftind == 4 ) THEN |
|---|
| 186 | IF (mpi_rank == PROC_VAL) WRITE(numout, *) "show_values_r4::"//TRIM(subrname)//"::"//TRIM(varname)//"=", SUM(SUM(var(PX_VAL,:,:,PFT_VAL),DIM=2)) |
|---|
| 187 | ELSE |
|---|
| 188 | CALL ipslerr_p(3,'show_values_r4','wrong pftind value','Allowed 2,3 or 4 but found:',pftind) |
|---|
| 189 | ENDIF |
|---|
| 190 | |
|---|
| 191 | END SUBROUTINE show_values_r4 |
|---|
| 192 | |
|---|
| 193 | ! |
|---|
| 194 | !! ================================================================================================================================ |
|---|
| 195 | !! SUBROUTINE : compare_results |
|---|
| 196 | !! |
|---|
| 197 | !>\BRIEF It checks whether all values are the same in original and test |
|---|
| 198 | !! |
|---|
| 199 | !! DESCRIPTION : It checks for all values of original and test array are the same. |
|---|
| 200 | !! Otherwise an error will be raised and the wrong values will be printed. |
|---|
| 201 | !! |
|---|
| 202 | !! This subroutines is meant to help developpers to ensure an improved |
|---|
| 203 | !! subroutine is giving the same results |
|---|
| 204 | !! |
|---|
| 205 | !! |
|---|
| 206 | !! RECENT CHANGE(S) : None |
|---|
| 207 | !! |
|---|
| 208 | !! REFERENCE(S) : None |
|---|
| 209 | !! |
|---|
| 210 | !! FLOWCHART : None |
|---|
| 211 | !! \n |
|---|
| 212 | !_ ================================================================================================================================ |
|---|
| 213 | SUBROUTINE compare_results_r2(calleer, subroutine_test, var_test, original, test) |
|---|
| 214 | CHARACTER(LEN=*), INTENT(in) :: calleer ! From where is called |
|---|
| 215 | CHARACTER(LEN=*), INTENT(in) :: subroutine_test ! Which subroutine is tested |
|---|
| 216 | CHARACTER(LEN=*), INTENT(in) :: var_test ! Variable to test |
|---|
| 217 | REAL(r_std), DIMENSION(:,:), INTENT(in) :: original ! Expected values |
|---|
| 218 | REAL(r_std), DIMENSION(:,:), INTENT(in) :: test ! New values to test |
|---|
| 219 | |
|---|
| 220 | INTEGER(i_std) :: ji, jv ! iterators |
|---|
| 221 | INTEGER(i_std) :: first, second ! |
|---|
| 222 | LOGICAL :: are_equal ! are original and test arrays equal? |
|---|
| 223 | |
|---|
| 224 | are_equal = .FALSE. |
|---|
| 225 | first = SIZE(original, DIM=1) ! first dimension size |
|---|
| 226 | second = SIZE(original, DIM=2) ! second dimension size |
|---|
| 227 | |
|---|
| 228 | DO ji=1, first |
|---|
| 229 | DO jv=1, second |
|---|
| 230 | IF (original(ji,jv) .NE. test(ji,jv)) THEN |
|---|
| 231 | WRITE(numout, *) var_test//"compare_results_r2:: i, j, original vs test=", & |
|---|
| 232 | ji,jv,original(ji,jv), test(ji,jv) |
|---|
| 233 | |
|---|
| 234 | are_equal = .TRUE. |
|---|
| 235 | ENDIF |
|---|
| 236 | ENDDO ! second |
|---|
| 237 | ENDDO ! first |
|---|
| 238 | |
|---|
| 239 | IF (are_equal) THEN |
|---|
| 240 | CALL ipslerr_p(3, 'compare_results_r2', 'Inside '//calleer, "Compared subroutines "//subroutine_test// "for variable "//var_test, 'Produce different values') |
|---|
| 241 | ENDIF |
|---|
| 242 | |
|---|
| 243 | END SUBROUTINE compare_results_r2 |
|---|
| 244 | |
|---|
| 245 | SUBROUTINE compare_results_r3(calleer, subroutine_test, var_test, original, test) |
|---|
| 246 | CHARACTER(LEN=*), INTENT(in) :: calleer ! From where is called |
|---|
| 247 | CHARACTER(LEN=*), INTENT(in) :: subroutine_test ! Which subroutine is tested |
|---|
| 248 | CHARACTER(LEN=*), INTENT(in) :: var_test ! Variable to test |
|---|
| 249 | REAL(r_std), DIMENSION(:,:,:), INTENT(in) :: original ! Expected values |
|---|
| 250 | REAL(r_std), DIMENSION(:,:,:), INTENT(in) :: test ! New values to test |
|---|
| 251 | |
|---|
| 252 | INTEGER(i_std) :: ji, jv, jk ! iterators |
|---|
| 253 | INTEGER(i_std) :: first, second, third ! |
|---|
| 254 | LOGICAL :: are_equal ! are original and test arrays equal? |
|---|
| 255 | |
|---|
| 256 | are_equal = .FALSE. |
|---|
| 257 | first = SIZE(original, DIM=1) ! first dimension size |
|---|
| 258 | second = SIZE(original, DIM=2) ! second dimension size |
|---|
| 259 | third = SIZE(original, DIM=3) ! third dimension size |
|---|
| 260 | |
|---|
| 261 | DO ji=1, first |
|---|
| 262 | DO jv=1, second |
|---|
| 263 | DO jk=1, third |
|---|
| 264 | IF (original(ji,jv,jk) .NE. test(ji,jv,jk)) THEN |
|---|
| 265 | WRITE(numout, *) var_test//"compare_results_r3:: i, j, k, original vs test=", & |
|---|
| 266 | ji,jv,jk,original(ji,jv,jk), test(ji,jv,jk) |
|---|
| 267 | |
|---|
| 268 | are_equal = .TRUE. |
|---|
| 269 | ENDIF |
|---|
| 270 | ENDDO ! third |
|---|
| 271 | ENDDO ! second |
|---|
| 272 | ENDDO ! first |
|---|
| 273 | |
|---|
| 274 | IF (are_equal) THEN |
|---|
| 275 | CALL ipslerr_p(3, 'compare_results_r3', 'Inside '//calleer, "Compared subroutines "//subroutine_test// "for variable "//var_test, 'Produce different values') |
|---|
| 276 | ENDIF |
|---|
| 277 | |
|---|
| 278 | END SUBROUTINE compare_results_r3 |
|---|
| 279 | |
|---|
| 280 | END MODULE utils |
|---|
