- Timestamp:
- Jul 24, 2024, 4:39:59 PM (4 months ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
LMDZ6/branches/Amaury_dev/libf/phylmd/create_limit_unstruct_mod.F90
r5117 r5118 1 1 MODULE create_limit_unstruct_mod 2 3 INTEGER, PARAMETER :: lmdep=124 5 2 PRIVATE 3 INTEGER, PARAMETER :: lmdep = 12 4 5 PUBLIC create_limit_unstruct 6 6 7 7 CONTAINS … … 9 9 10 10 SUBROUTINE create_limit_unstruct 11 USE dimphy12 USE lmdz_xios13 USE ioipsl,ONLY: ioget_year_len14 USE time_phylmdz_mod, ONLY: annee_ref15 USE indice_sol_mod16 USE phys_state_var_mod17 USE lmdz_phys_para18 USE lmdz_abort_physic, ONLY: abort_physic19 IMPLICIT NONE20 I NCLUDE "iniprint.h"21 REAL, DIMENSION(:,:),ALLOCATABLE:: sic22 REAL, DIMENSION(:,:),ALLOCATABLE:: sst23 REAL, DIMENSION(klon,lmdep):: rugos24 REAL, DIMENSION(klon,lmdep):: albedo25 REAL, DIMENSION(:,:),ALLOCATABLE:: sic_mpi26 REAL, DIMENSION(:,:),ALLOCATABLE:: sst_mpi27 REAL, DIMENSION(klon_mpi,lmdep):: rugos_mpi28 REAL, DIMENSION(klon_mpi,lmdep):: albedo_mpi29 INTEGER 30 REAL 31 REAL, ALLOCATABLE :: sic_year(:,:)32 REAL, ALLOCATABLE :: sst_year(:,:)33 REAL, ALLOCATABLE :: rugos_year(:,:)34 REAL, ALLOCATABLE :: albedo_year(:,:)35 REAL, ALLOCATABLE :: pctsrf_t(:,:,:)36 REAL, ALLOCATABLE :: phy_bil(:,:)37 REAL, ALLOCATABLE :: sst_year_mpi(:,:)38 REAL, ALLOCATABLE :: rugos_year_mpi(:,:)39 REAL, ALLOCATABLE :: albedo_year_mpi(:,:)40 REAL, ALLOCATABLE :: pctsrf_t_mpi(:,:,:)41 REAL, ALLOCATABLE :: phy_bil_mpi(:,:)42 INTEGER :: l, k11 USE dimphy 12 USE lmdz_xios 13 USE ioipsl, ONLY: ioget_year_len 14 USE time_phylmdz_mod, ONLY: annee_ref 15 USE indice_sol_mod 16 USE phys_state_var_mod 17 USE lmdz_phys_para 18 USE lmdz_abort_physic, ONLY: abort_physic 19 USE lmdz_iniprint, ONLY: lunout, prt_level 20 IMPLICIT NONE 21 REAL, DIMENSION(:, :), ALLOCATABLE :: sic 22 REAL, DIMENSION(:, :), ALLOCATABLE :: sst 23 REAL, DIMENSION(klon, lmdep) :: rugos 24 REAL, DIMENSION(klon, lmdep) :: albedo 25 REAL, DIMENSION(:, :), ALLOCATABLE :: sic_mpi 26 REAL, DIMENSION(:, :), ALLOCATABLE :: sst_mpi 27 REAL, DIMENSION(klon_mpi, lmdep) :: rugos_mpi 28 REAL, DIMENSION(klon_mpi, lmdep) :: albedo_mpi 29 INTEGER :: ndays 30 REAL :: fi_ice(klon) 31 REAL, ALLOCATABLE :: sic_year(:, :) 32 REAL, ALLOCATABLE :: sst_year(:, :) 33 REAL, ALLOCATABLE :: rugos_year(:, :) 34 REAL, ALLOCATABLE :: albedo_year(:, :) 35 REAL, ALLOCATABLE :: pctsrf_t(:, :, :) 36 REAL, ALLOCATABLE :: phy_bil(:, :) 37 REAL, ALLOCATABLE :: sst_year_mpi(:, :) 38 REAL, ALLOCATABLE :: rugos_year_mpi(:, :) 39 REAL, ALLOCATABLE :: albedo_year_mpi(:, :) 40 REAL, ALLOCATABLE :: pctsrf_t_mpi(:, :, :) 41 REAL, ALLOCATABLE :: phy_bil_mpi(:, :) 42 INTEGER :: l, k 43 43 INTEGER :: nbad 44 INTEGER :: sic_time_axis_size 44 INTEGER :: sic_time_axis_size 45 45 INTEGER :: sst_time_axis_size 46 CHARACTER(LEN=99) :: mess ! error message 47 48 49 ndays=ioget_year_len(annee_ref) 50 51 IF (is_omp_master) CALL xios_get_axis_attr("time_sic",n_glo=sic_time_axis_size) 46 CHARACTER(LEN = 99) :: mess ! error message 47 48 ndays = ioget_year_len(annee_ref) 49 50 IF (is_omp_master) CALL xios_get_axis_attr("time_sic", n_glo = sic_time_axis_size) 52 51 CALL bcast_omp(sic_time_axis_size) 53 ALLOCATE(sic_mpi(klon_mpi,sic_time_axis_size)) 54 ALLOCATE(sic(klon,sic_time_axis_size)) 55 56 57 IF (is_omp_master) CALL xios_get_axis_attr("time_sst",n_glo=sst_time_axis_size) 52 ALLOCATE(sic_mpi(klon_mpi, sic_time_axis_size)) 53 ALLOCATE(sic(klon, sic_time_axis_size)) 54 55 IF (is_omp_master) CALL xios_get_axis_attr("time_sst", n_glo = sst_time_axis_size) 58 56 CALL bcast_omp(sst_time_axis_size) 59 ALLOCATE(sst_mpi(klon_mpi, sst_time_axis_size))60 ALLOCATE(sst(klon, sst_time_axis_size))61 57 ALLOCATE(sst_mpi(klon_mpi, sst_time_axis_size)) 58 ALLOCATE(sst(klon, sst_time_axis_size)) 59 62 60 IF (is_omp_master) THEN 63 CALL xios_recv_field("sic_limit", sic_mpi)64 CALL xios_recv_field("sst_limit", sst_mpi)65 CALL xios_recv_field("rugos_limit", rugos_mpi)66 CALL xios_recv_field("albedo_limit", albedo_mpi)67 ENDIF 68 CALL scatter_omp(sic_mpi, sic)69 CALL scatter_omp(sst_mpi, sst)70 CALL scatter_omp(rugos_mpi, rugos)71 CALL scatter_omp(albedo_mpi, albedo)72 73 ALLOCATE(sic_year(klon, ndays))74 ALLOCATE(sst_year(klon, ndays))75 ALLOCATE(rugos_year(klon, ndays))76 ALLOCATE(albedo_year(klon, ndays))77 ALLOCATE(pctsrf_t(klon, nbsrf,ndays))78 ALLOCATE(phy_bil(klon, ndays)); phy_bil=0.079 80 81 ! sic61 CALL xios_recv_field("sic_limit", sic_mpi) 62 CALL xios_recv_field("sst_limit", sst_mpi) 63 CALL xios_recv_field("rugos_limit", rugos_mpi) 64 CALL xios_recv_field("albedo_limit", albedo_mpi) 65 ENDIF 66 CALL scatter_omp(sic_mpi, sic) 67 CALL scatter_omp(sst_mpi, sst) 68 CALL scatter_omp(rugos_mpi, rugos) 69 CALL scatter_omp(albedo_mpi, albedo) 70 71 ALLOCATE(sic_year(klon, ndays)) 72 ALLOCATE(sst_year(klon, ndays)) 73 ALLOCATE(rugos_year(klon, ndays)) 74 ALLOCATE(albedo_year(klon, ndays)) 75 ALLOCATE(pctsrf_t(klon, nbsrf, ndays)) 76 ALLOCATE(phy_bil(klon, ndays)); phy_bil = 0.0 77 78 79 ! sic 82 80 IF (sic_time_axis_size==lmdep) THEN 83 CALL time_interpolation(ndays, sic,'gregorian',sic_year)81 CALL time_interpolation(ndays, sic, 'gregorian', sic_year) 84 82 ELSE IF (sic_time_axis_size==ndays) THEN 85 sic_year =sic83 sic_year = sic 86 84 ELSE 87 WRITE(mess, *) 'sic time axis is nor montly, nor daily. sic time interpolation ',&88 89 CALL abort_physic('create_limit_unstruct', TRIM(mess),1)90 ENDIF 91 92 sic_year(:, :)=sic_year(:,:)/100. ! convert percent to fraction93 WHERE(sic_year(:, :)>1.0) sic_year(:,:)=1.0 ! Some fractions have some time large negative values94 WHERE(sic_year(:, :)<0.0) sic_year(:,:)=0.0 ! probably better to apply alse this filter before horizontal interpolation95 96 ! sst85 WRITE(mess, *) 'sic time axis is nor montly, nor daily. sic time interpolation ', & 86 'is requiered but is not currently managed' 87 CALL abort_physic('create_limit_unstruct', TRIM(mess), 1) 88 ENDIF 89 90 sic_year(:, :) = sic_year(:, :) / 100. ! convert percent to fraction 91 WHERE(sic_year(:, :)>1.0) sic_year(:, :) = 1.0 ! Some fractions have some time large negative values 92 WHERE(sic_year(:, :)<0.0) sic_year(:, :) = 0.0 ! probably better to apply alse this filter before horizontal interpolation 93 94 ! sst 97 95 IF (sst_time_axis_size==lmdep) THEN 98 CALL time_interpolation(ndays, sst,'gregorian',sst_year)96 CALL time_interpolation(ndays, sst, 'gregorian', sst_year) 99 97 ELSE IF (sst_time_axis_size==ndays) THEN 100 sst_year =sst98 sst_year = sst 101 99 ELSE 102 WRITE(mess, *)'sic time axis is nor montly, nor daily. sic time interpolation ',&103 104 CALL abort_physic('create_limit_unstruct', TRIM(mess),1)105 ENDIF 106 WHERE(sst_year(:, :)<271.38) sst_year(:,:)=271.38107 108 109 ! rugos 110 DO l =1, lmdep111 WHERE(NINT(zmasq(:))/=1) rugos(:, l)=0.001100 WRITE(mess, *)'sic time axis is nor montly, nor daily. sic time interpolation ', & 101 'is requiered but is not currently managed' 102 CALL abort_physic('create_limit_unstruct', TRIM(mess), 1) 103 ENDIF 104 WHERE(sst_year(:, :)<271.38) sst_year(:, :) = 271.38 105 106 107 ! rugos 108 DO l = 1, lmdep 109 WHERE(NINT(zmasq(:))/=1) rugos(:, l) = 0.001 112 110 ENDDO 113 CALL time_interpolation(ndays,rugos,'360_day',rugos_year) 114 115 ! albedo 116 CALL time_interpolation(ndays,albedo,'360_day',albedo_year) 117 118 119 DO k=1,ndays 120 fi_ice=sic_year(:,k) 121 WHERE(fi_ice>=1.0 ) fi_ice=1.0 122 WHERE(fi_ice<EPSFRA) fi_ice=0.0 123 pctsrf_t(:,is_ter,k)=pctsrf(:,is_ter) ! land soil 124 pctsrf_t(:,is_lic,k)=pctsrf(:,is_lic) ! land ice 125 126 !! IF (icefile==trim(fcpldsic)) THEN ! SIC=pICE*(1-LIC-TER) 127 !! pctsrf_t(:,is_sic,k)=fi_ice(:)*(1.-pctsrf(:,is_lic)-pctsrf(:,is_ter)) 128 !! ELSE IF (icefile==trim(fhistsic)) THEN ! SIC=pICE 129 !! pctsrf_t(:,is_sic,k)=fi_ice(:) 130 !! ELSE ! icefile==famipsic ! SIC=pICE-LIC 131 pctsrf_t(:,is_sic,k)=fi_ice-pctsrf_t(:,is_lic,k) 132 ! END IF 133 WHERE(pctsrf_t(:,is_sic,k)<=0) pctsrf_t(:,is_sic,k)=0. 134 WHERE(1.0-zmasq<EPSFRA) 135 pctsrf_t(:,is_sic,k)=0.0 136 pctsrf_t(:,is_oce,k)=0.0 111 CALL time_interpolation(ndays, rugos, '360_day', rugos_year) 112 113 ! albedo 114 CALL time_interpolation(ndays, albedo, '360_day', albedo_year) 115 116 DO k = 1, ndays 117 fi_ice = sic_year(:, k) 118 WHERE(fi_ice>=1.0) fi_ice = 1.0 119 WHERE(fi_ice<EPSFRA) fi_ice = 0.0 120 pctsrf_t(:, is_ter, k) = pctsrf(:, is_ter) ! land soil 121 pctsrf_t(:, is_lic, k) = pctsrf(:, is_lic) ! land ice 122 123 !! IF (icefile==trim(fcpldsic)) THEN ! SIC=pICE*(1-LIC-TER) 124 !! pctsrf_t(:,is_sic,k)=fi_ice(:)*(1.-pctsrf(:,is_lic)-pctsrf(:,is_ter)) 125 !! ELSE IF (icefile==trim(fhistsic)) THEN ! SIC=pICE 126 !! pctsrf_t(:,is_sic,k)=fi_ice(:) 127 !! ELSE ! icefile==famipsic ! SIC=pICE-LIC 128 pctsrf_t(:, is_sic, k) = fi_ice - pctsrf_t(:, is_lic, k) 129 ! END IF 130 WHERE(pctsrf_t(:, is_sic, k)<=0) pctsrf_t(:, is_sic, k) = 0. 131 WHERE(1.0 - zmasq<EPSFRA) 132 pctsrf_t(:, is_sic, k) = 0.0 133 pctsrf_t(:, is_oce, k) = 0.0 137 134 ELSEWHERE 138 WHERE(pctsrf_t(:, is_sic,k)>=1.0-zmasq)139 pctsrf_t(:, is_sic,k)=1.0-zmasq140 pctsrf_t(:, is_oce,k)=0.0135 WHERE(pctsrf_t(:, is_sic, k)>=1.0 - zmasq) 136 pctsrf_t(:, is_sic, k) = 1.0 - zmasq 137 pctsrf_t(:, is_oce, k) = 0.0 141 138 ELSEWHERE 142 pctsrf_t(:, is_oce,k)=1.0-zmasq-pctsrf_t(:,is_sic,k)143 WHERE(pctsrf_t(:, is_oce,k)<EPSFRA)144 pctsrf_t(:,is_oce,k)=0.0145 pctsrf_t(:,is_sic,k)=1.0-zmasq139 pctsrf_t(:, is_oce, k) = 1.0 - zmasq - pctsrf_t(:, is_sic, k) 140 WHERE(pctsrf_t(:, is_oce, k)<EPSFRA) 141 pctsrf_t(:, is_oce, k) = 0.0 142 pctsrf_t(:, is_sic, k) = 1.0 - zmasq 146 143 END WHERE 147 144 END WHERE 148 145 END WHERE 149 nbad =COUNT(pctsrf_t(:,is_oce,k)<0.0)150 IF(nbad>0) WRITE(lunout, *) 'pb sous maille pour nb point = ',nbad151 nbad =COUNT(abs(sum(pctsrf_t(:,:,k),dim=2)-1.0)>EPSFRA)152 IF(nbad>0) WRITE(lunout, *) 'pb sous surface pour nb points = ',nbad146 nbad = COUNT(pctsrf_t(:, is_oce, k)<0.0) 147 IF(nbad>0) WRITE(lunout, *) 'pb sous maille pour nb point = ', nbad 148 nbad = COUNT(abs(sum(pctsrf_t(:, :, k), dim = 2) - 1.0)>EPSFRA) 149 IF(nbad>0) WRITE(lunout, *) 'pb sous surface pour nb points = ', nbad 153 150 END DO 154 155 ALLOCATE(sst_year_mpi(klon_mpi, ndays))156 ALLOCATE(rugos_year_mpi(klon_mpi, ndays))157 ALLOCATE(albedo_year_mpi(klon_mpi, ndays))158 ALLOCATE(pctsrf_t_mpi(klon_mpi, nbsrf,ndays))159 ALLOCATE(phy_bil_mpi(klon_mpi, ndays))160 161 CALL gather_omp(pctsrf_t 162 CALL gather_omp(sst_year 163 CALL gather_omp(phy_bil 151 152 ALLOCATE(sst_year_mpi(klon_mpi, ndays)) 153 ALLOCATE(rugos_year_mpi(klon_mpi, ndays)) 154 ALLOCATE(albedo_year_mpi(klon_mpi, ndays)) 155 ALLOCATE(pctsrf_t_mpi(klon_mpi, nbsrf, ndays)) 156 ALLOCATE(phy_bil_mpi(klon_mpi, ndays)) 157 158 CALL gather_omp(pctsrf_t, pctsrf_t_mpi) 159 CALL gather_omp(sst_year, sst_year_mpi) 160 CALL gather_omp(phy_bil, phy_bil_mpi) 164 161 CALL gather_omp(albedo_year, albedo_year_mpi) 165 CALL gather_omp(rugos_year 162 CALL gather_omp(rugos_year, rugos_year_mpi) 166 163 167 164 IF (is_omp_master) THEN 168 CALL xios_send_field("foce_limout", pctsrf_t_mpi(:,is_oce,:))169 CALL xios_send_field("fsic_limout", pctsrf_t_mpi(:,is_sic,:))170 CALL xios_send_field("fter_limout", pctsrf_t_mpi(:,is_ter,:))171 CALL xios_send_field("flic_limout", pctsrf_t_mpi(:,is_lic,:))165 CALL xios_send_field("foce_limout", pctsrf_t_mpi(:, is_oce, :)) 166 CALL xios_send_field("fsic_limout", pctsrf_t_mpi(:, is_sic, :)) 167 CALL xios_send_field("fter_limout", pctsrf_t_mpi(:, is_ter, :)) 168 CALL xios_send_field("flic_limout", pctsrf_t_mpi(:, is_lic, :)) 172 169 CALL xios_send_field("sst_limout", sst_year_mpi) 173 CALL xios_send_field("bils_limout", phy_bil_mpi)174 CALL xios_send_field("alb_limout", albedo_year_mpi) 175 CALL xios_send_field("rug_limout", rugos_year_mpi) 170 CALL xios_send_field("bils_limout", phy_bil_mpi) 171 CALL xios_send_field("alb_limout", albedo_year_mpi) 172 CALL xios_send_field("rug_limout", rugos_year_mpi) 176 173 ENDIF 177 174 END SUBROUTINE create_limit_unstruct 178 179 180 SUBROUTINE time_interpolation(ndays,field_in,calendar,field_out) 181 USE lmdz_libmath_pch, ONLY: pchsp_95, pchfe_95 182 USE lmdz_arth, ONLY: arth 183 USE dimphy, ONLY: klon 184 USE ioipsl, ONLY: ioget_year_len 185 USE time_phylmdz_mod, ONLY: annee_ref 186 USE lmdz_phys_para 187 USE lmdz_abort_physic, ONLY: abort_physic 188 IMPLICIT NONE 189 INCLUDE "iniprint.h" 190 191 INTEGER, INTENT(IN) :: ndays 192 REAL, INTENT(IN) :: field_in(klon,lmdep) 193 CHARACTER(LEN=*),INTENT(IN) :: calendar 194 REAL, INTENT(OUT) :: field_out(klon,ndays) 195 196 INTEGER :: ndays_in 197 REAL :: timeyear(lmdep) 198 REAL :: yder(lmdep) 199 INTEGER :: ij,ierr, n_extrap 200 LOGICAL :: skip 201 202 CHARACTER (len = 50) :: modname = 'create_limit_unstruct.time_interpolation' 203 CHARACTER (len = 80) :: abort_message 204 205 206 IF (is_omp_master) ndays_in=year_len(annee_ref, calendar) 207 CALL bcast_omp(ndays_in) 208 IF (is_omp_master) timeyear=mid_months(annee_ref, calendar, lmdep) 209 CALL bcast_omp(timeyear) 210 211 n_extrap = 0 212 skip=.FALSE. 213 DO ij=1,klon 214 yder = pchsp_95(timeyear, field_in(ij, :), ibeg=2, iend=2, vc_beg=0., vc_end=0.) 215 CALL pchfe_95(timeyear, field_in(ij, :), yder, skip, arth(0., real(ndays_in) / ndays, ndays), field_out(ij, :), ierr) 216 IF (ierr < 0) THEN 217 abort_message='error in pchfe_95' 218 CALL abort_physic(modname,abort_message,1) 219 endif 220 n_extrap = n_extrap + ierr 221 END DO 222 223 IF (n_extrap /= 0) THEN 224 WRITE(lunout,*) "get_2Dfield pchfe_95: n_extrap = ", n_extrap 225 ENDIF 226 227 175 176 177 SUBROUTINE time_interpolation(ndays, field_in, calendar, field_out) 178 USE lmdz_libmath_pch, ONLY: pchsp_95, pchfe_95 179 USE lmdz_arth, ONLY: arth 180 USE dimphy, ONLY: klon 181 USE ioipsl, ONLY: ioget_year_len 182 USE time_phylmdz_mod, ONLY: annee_ref 183 USE lmdz_phys_para 184 USE lmdz_abort_physic, ONLY: abort_physic 185 USE lmdz_iniprint, ONLY: lunout, prt_level 186 IMPLICIT NONE 187 188 INTEGER, INTENT(IN) :: ndays 189 REAL, INTENT(IN) :: field_in(klon, lmdep) 190 CHARACTER(LEN = *), INTENT(IN) :: calendar 191 REAL, INTENT(OUT) :: field_out(klon, ndays) 192 193 INTEGER :: ndays_in 194 REAL :: timeyear(lmdep) 195 REAL :: yder(lmdep) 196 INTEGER :: ij, ierr, n_extrap 197 LOGICAL :: skip 198 199 CHARACTER (len = 50) :: modname = 'create_limit_unstruct.time_interpolation' 200 CHARACTER (len = 80) :: abort_message 201 202 IF (is_omp_master) ndays_in = year_len(annee_ref, calendar) 203 CALL bcast_omp(ndays_in) 204 IF (is_omp_master) timeyear = mid_months(annee_ref, calendar, lmdep) 205 CALL bcast_omp(timeyear) 206 207 n_extrap = 0 208 skip = .FALSE. 209 DO ij = 1, klon 210 yder = pchsp_95(timeyear, field_in(ij, :), ibeg = 2, iend = 2, vc_beg = 0., vc_end = 0.) 211 CALL pchfe_95(timeyear, field_in(ij, :), yder, skip, arth(0., real(ndays_in) / ndays, ndays), field_out(ij, :), ierr) 212 IF (ierr < 0) THEN 213 abort_message = 'error in pchfe_95' 214 CALL abort_physic(modname, abort_message, 1) 215 endif 216 n_extrap = n_extrap + ierr 217 END DO 218 219 IF (n_extrap /= 0) THEN 220 WRITE(lunout, *) "get_2Dfield pchfe_95: n_extrap = ", n_extrap 221 ENDIF 222 228 223 END SUBROUTINE time_interpolation 229 224 !------------------------------------------------------------------------------- 230 225 231 FUNCTION year_len(y,cal_in) 226 FUNCTION year_len(y, cal_in) 227 228 !------------------------------------------------------------------------------- 229 USE ioipsl, ONLY: ioget_calendar, ioconf_calendar, lock_calendar, ioget_year_len 230 IMPLICIT NONE 231 !------------------------------------------------------------------------------- 232 ! Arguments: 233 INTEGER :: year_len 234 INTEGER, INTENT(IN) :: y 235 CHARACTER(LEN = *), INTENT(IN) :: cal_in 236 !------------------------------------------------------------------------------- 237 ! Local variables: 238 CHARACTER(LEN = 20) :: cal_out ! calendar (for outputs) 239 !------------------------------------------------------------------------------- 240 !--- Getting the input calendar to reset at the end of the function 241 CALL ioget_calendar(cal_out) 242 243 !--- Unlocking calendar and setting it to wanted one 244 CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_in)) 245 246 !--- Getting the number of days in this year 247 year_len = ioget_year_len(y) 248 249 !--- Back to original calendar 250 CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_out)) 251 252 END FUNCTION year_len 232 253 233 254 !------------------------------------------------------------------------------- 234 USE ioipsl, ONLY: ioget_calendar,ioconf_calendar,lock_calendar,ioget_year_len 235 IMPLICIT NONE 255 256 236 257 !------------------------------------------------------------------------------- 237 ! Arguments: 238 INTEGER :: year_len 239 INTEGER, INTENT(IN) :: y 240 CHARACTER(LEN=*), INTENT(IN) :: cal_in 241 !------------------------------------------------------------------------------- 242 ! Local variables: 243 CHARACTER(LEN=20) :: cal_out ! calendar (for outputs) 244 !------------------------------------------------------------------------------- 245 !--- Getting the input calendar to reset at the end of the function 246 CALL ioget_calendar(cal_out) 247 248 !--- Unlocking calendar and setting it to wanted one 249 CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_in)) 250 251 !--- Getting the number of days in this year 252 year_len=ioget_year_len(y) 253 254 !--- Back to original calendar 255 CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_out)) 256 257 END FUNCTION year_len 258 259 !------------------------------------------------------------------------------- 260 261 262 !------------------------------------------------------------------------------- 263 264 FUNCTION mid_months(y,cal_in,nm) 265 266 !------------------------------------------------------------------------------- 267 USE ioipsl, ONLY: ioget_calendar,ioconf_calendar,lock_calendar,ioget_mon_len 258 259 FUNCTION mid_months(y, cal_in, nm) 260 261 !------------------------------------------------------------------------------- 262 USE ioipsl, ONLY: ioget_calendar, ioconf_calendar, lock_calendar, ioget_mon_len 268 263 USE lmdz_abort_physic, ONLY: abort_physic 269 264 IMPLICIT NONE 270 !-------------------------------------------------------------------------------271 ! Arguments:272 INTEGER, 273 CHARACTER(LEN =*),INTENT(IN) :: cal_in ! calendar274 INTEGER, 275 REAL, DIMENSION(nm):: mid_months ! mid-month times276 !-------------------------------------------------------------------------------277 ! Local variables:278 CHARACTER(LEN =99):: mess ! error message279 CHARACTER(LEN =20):: cal_out ! calendar (for outputs)280 INTEGER, DIMENSION(nm) 281 INTEGER 282 INTEGER 283 INTEGER 284 !-------------------------------------------------------------------------------285 nd =year_len(y,cal_in)286 265 !------------------------------------------------------------------------------- 266 ! Arguments: 267 INTEGER, INTENT(IN) :: y ! year 268 CHARACTER(LEN = *), INTENT(IN) :: cal_in ! calendar 269 INTEGER, INTENT(IN) :: nm ! months/year number 270 REAL, DIMENSION(nm) :: mid_months ! mid-month times 271 !------------------------------------------------------------------------------- 272 ! Local variables: 273 CHARACTER(LEN = 99) :: mess ! error message 274 CHARACTER(LEN = 20) :: cal_out ! calendar (for outputs) 275 INTEGER, DIMENSION(nm) :: mnth ! months lengths (days) 276 INTEGER :: m ! months counter 277 INTEGER :: nd ! number of days 278 INTEGER :: k 279 !------------------------------------------------------------------------------- 280 nd = year_len(y, cal_in) 281 287 282 IF(nm==12) THEN 288 289 !--- Getting the input calendar to reset at the end of the function283 284 !--- Getting the input calendar to reset at the end of the function 290 285 CALL ioget_calendar(cal_out) 291 292 !--- Unlocking calendar and setting it to wanted one286 287 !--- Unlocking calendar and setting it to wanted one 293 288 CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_in)) 294 295 !--- Getting the length of each month 296 DO m=1,nm; mnth(m)=ioget_mon_len(y,m); END DO 297 298 !--- Back to original calendar 289 290 !--- Getting the length of each month 291 DO m = 1, nm; mnth(m) = ioget_mon_len(y, m); 292 END DO 293 294 !--- Back to original calendar 299 295 CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_out)) 300 301 ELSE IF(MODULO(nd, nm)/=0) THEN302 WRITE(mess, '(a,i3,a,i3,a)')'Unconsistent calendar: ',nd,' days/year, but ',&303 nm,' months/year. Months number should divide days number.'304 CALL abort_physic('mid_months', TRIM(mess),1)305 296 297 ELSE IF(MODULO(nd, nm)/=0) THEN 298 WRITE(mess, '(a,i3,a,i3,a)')'Unconsistent calendar: ', nd, ' days/year, but ', & 299 nm, ' months/year. Months number should divide days number.' 300 CALL abort_physic('mid_months', TRIM(mess), 1) 301 306 302 ELSE 307 mnth =(/(m,m=1,nm,nd/nm)/)303 mnth = (/(m, m = 1, nm, nd / nm)/) 308 304 END IF 309 310 !--- Mid-months times311 mid_months(1) =0.5*REAL(mnth(1))312 DO k =2,nm313 mid_months(k) =mid_months(k-1)+0.5*REAL(mnth(k-1)+mnth(k))305 306 !--- Mid-months times 307 mid_months(1) = 0.5 * REAL(mnth(1)) 308 DO k = 2, nm 309 mid_months(k) = mid_months(k - 1) + 0.5 * REAL(mnth(k - 1) + mnth(k)) 314 310 END DO 315 311 316 312 END FUNCTION mid_months 317 313 318 314 319 315 END MODULE create_limit_unstruct_mod
Note: See TracChangeset
for help on using the changeset viewer.
