! -*- Mode: f90 -*- MODULE modeles !> Declare tous les tableaux !! USE declare USE dimensions USE mod_prih !! IMPLICIT NONE !! SAVE PUBLIC !! REAL (kind=rl), PARAMETER :: eps = EPSILON (1.0_rl) !< Standard precision epsilon REAL (kind=rl), PARAMETER :: eps10 = 10.0_rl * eps !< Standard precision epsilon * 10 REAL (kind=rl), PARAMETER :: epsd = EPSILON (1.0_rd) !< Quadruple precision epsilon REAL (kind=rl), PARAMETER :: epsd10 = 10.0_rd * epsd !< Quadruple precision epsilon * 10 !! !! REAL (kind=rl), DIMENSION (:), ALLOCATABLE :: yas, yan, xaw, xae !< Limits of atmos box (south, north, west, east) REAL (kind=rl), DIMENSION (:), ALLOCATABLE :: yos, yon, xow, xoe !< Limits of atmos box (south, north, west, east) REAL (kind=rl), DIMENSION (:), ALLOCATABLE :: xolont, xolatt, xosrft !< Lon, lat and surface at T point for ocean REAL (kind=rl), DIMENSION (:), ALLOCATABLE :: xolonu, xolatu, xosrfu !< idem point u REAL (kind=rl), DIMENSION (:), ALLOCATABLE :: xolonv, xolatv, xosrfv !< idem point v REAL (kind=rl), DIMENSION (:), ALLOCATABLE :: xolonf, xolatf, xosrff !< idem point f REAL (kind=rl), DIMENSION (:), ALLOCATABLE :: xalont, xalatt, xasrft !< For atmosphere REAL (kind=rl), DIMENSION (:), ALLOCATABLE :: xalonu, xalatu, xasrfu REAL (kind=rl), DIMENSION (:), ALLOCATABLE :: xalonv, xalatv, xasrfv REAL (kind=rl), DIMENSION (:), ALLOCATABLE :: xasrft_pol, xosrft_pol !< Surfaces calculées par les polygones. INTEGER (kind=il), DIMENSION (:), ALLOCATABLE :: nborda !< 1 if atmosphere point is over some land point of ocean grid INTEGER (kind=il), DIMENSION (:), ALLOCATABLE :: nbordo !< 1 if ocean point is over some land point of atmos grid REAL (kind=rl) , DIMENSION (:,:), ALLOCATABLE :: wo2a !< Weigts of interpolation ocean -> atmosphere INTEGER(kind=il) , DIMENSION (:,:), ALLOCATABLE :: ko2a !< Adresses ocean -> atmosphere REAL (kind=rl) , DIMENSION (:,:), ALLOCATABLE :: wa2o !< Weights of interpolation atmosphere -> ocean INTEGER (kind=il), DIMENSION (:,:), ALLOCATABLE :: ka2o ! Adresses atmosphere -> ocean REAL (kind=rl) , DIMENSION (:), ALLOCATABLE :: wasum !< Sum of weights of interpolation atmosphere -> ocean REAL (kind=rl) , DIMENSION (:), ALLOCATABLE :: wosum !< Sum of weights of interpolation ocean -> atmosphere INTEGER (kind=il), DIMENSION (:), ALLOCATABLE :: nva !< Number of ocean neighbor for each atm point INTEGER (kind=il), DIMENSION (:), ALLOCATABLE :: nvo !< Number of atmos neighbor for each ocean point INTEGER (kind=il), DIMENSION (:), ALLOCATABLE :: iomskt, iomsku, iomskv, iomskf !< Mask ocean model (sea=0, land=1) INTEGER (kind=il), DIMENSION (:), ALLOCATABLE :: iamskt, iamsku, iamskv !< Mask atm model (sea=0, land=1) INTEGER (kind=il), DIMENSION (:), ALLOCATABLE :: iamskp !< Mask to remove redundant point by periodicity and north folding INTEGER (kind=il), DIMENSION (:), ALLOCATABLE :: iomskp !< Mask to remove redundant point by periodicity and north folding REAL (kind=rl) , DIMENSION (:, :), ALLOCATABLE :: xo_ed !< Longitude of corner of oce boxes !< UL,UM,UR,MR,LR,LM,LL,ML.9 for middle of box REAL (kind=rl) , DIMENSION (:, :), ALLOCATABLE :: yo_ed !< Lat REAL (kind=rl) , DIMENSION (:, :), ALLOCATABLE :: xa_ed !< Atm REAL (kind=rl) , DIMENSION (:, :), ALLOCATABLE :: ya_ed !! CHARACTER (LEN=4) :: comod_a, comod_t, comod_u, comod_v, comod_f CHARACTER (LEN=4) :: camod_a, camod_t, camod_u, camod_v, camod_f !! INTEGER (kind=il) :: maxo, maxa ! INTEGER (kind=il) :: nsum !< Ponderation suivant le type de point trouve !! REAL (kind=rl) :: xinf, xsup !< Longitudes minimales et maximales de travail INTEGER (kind=il) :: ngrd, nsrf, nmsk, nwei4o2a, nwei4a2o, nwei8o2a, nwei8a2o, nchk, ndeb, nbug1, nwei8, nwei4 !< IO unit numbers !! REAL (kind=rl) :: ra = 6371229.0_rl !< Earth Radius (for OPA) REAL (kind=rl) :: xsurfa, xsurfo !< Earth surface in each model !! CHARACTER (LEN = 8) :: cladress, clweight !< Name of OASIS weights/adresses ! REAL(kind=rl), DIMENSION (:), ALLOCATABLE :: o2amask !< Ocean mask interpolated toward atmosphere REAL(kind=rl), DIMENSION (:), ALLOCATABLE :: a2omask !< Atmosphere mask interpolated toward ocean REAL(kind=rl), DIMENSION (:), ALLOCATABLE :: o2afull !< 1 on ocean interpolated toward atmosphere REAL(kind=rl), DIMENSION (:), ALLOCATABLE :: a2ofull !< 1 on atmosphere interpolated toward ocean ! INTEGER, DIMENSION (:), ALLOCATABLE :: o2amask_i_int !< Ocean mask interpolated toward atmosphere : full land only INTEGER, DIMENSION (:), ALLOCATABLE :: o2amask_i_ext !< Ocean mask interpolated toward atmosphere : all points with some land INTEGER, DIMENSION (:), ALLOCATABLE :: a2omask_i_int !< Atmosphere mask interpolated toward ocean : full land only INTEGER, DIMENSION (:), ALLOCATABLE :: a2omask_i_ext !< Atmosphere mask interpolated toward ocean : all points with some land !! INTEGER (kind = il), DIMENSION (:), ALLOCATABLE :: m2ai, m2aj, m2oi, m2oj, moi, moj, mai, maj INTEGER (kind = il), DIMENSION (:, :), ALLOCATABLE :: m1a, m1ar, m1o, m1or !! CONTAINS !! SUBROUTINE alloc_modeles !> Dimensionne tout les tableaux necessaires IMPLICIT NONE !! INTEGER (kind=il) :: ja, jo, jai, jaj, joi, joj INTEGER :: ierr !! WRITE (nout, *) 'Data types ' WRITE (nout, *) 'r_4 : ', r_4, 1.0_r_4, TINY(1.0_r_4), HUGE(1.0_r_4), EPSILON (1.0_r_4) WRITE (nout, *) 'r_8 : ', r_8, 1.0_r_8, TINY(1.0_r_8), HUGE(1.0_r_8), EPSILON (1.0_r_8) WRITE (nout, *) 'rd : ', rd , 1.0_rd , TINY(1.0_rd) , HUGE(1.0_rd) , EPSILON (1.0_rd) WRITE (nout, *) 'rl : ', rl , 1.0_rl , TINY(1.0_rl) , HUGE(1.0_rl) , EPSILON (1.0_rl) !! ALLOCATE (yas (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'yas', lreset = .TRUE., crout = 'common') ALLOCATE (yan (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'yan') ALLOCATE (xaw (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'xaw') ALLOCATE (xae (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'xae') ALLOCATE (yos (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'yos') ALLOCATE (yon (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'yon') ALLOCATE (xow (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xow') ALLOCATE (xoe (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xoe') ! ALLOCATE (xolont (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xolont') ALLOCATE (xolonu (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xolonu') ALLOCATE (xolonv (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xolonv') ALLOCATE (xolonf (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xolonf') ALLOCATE (xolatt (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xolatt') ALLOCATE (xolatu (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xolatu') ALLOCATE (xolatv (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xolatv') ALLOCATE (xolatf (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xolatf') ALLOCATE (xosrft (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xosrft') ALLOCATE (xosrfu (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xosrfu') ALLOCATE (xosrfv (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xosrfv') ALLOCATE (xosrff (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xosrff') ! ALLOCATE (xosrft_pol (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'xosrft_pol') ALLOCATE (xasrft_pol (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'xasrft_pol') ! ALLOCATE (xalont (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'xalont') ALLOCATE (xalonu (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'xalonu') ALLOCATE (xalonv (jpanv), STAT=ierr) ; CALL chk_allo (ierr, 'xalonv') ALLOCATE (xalatt (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'xalatt') ALLOCATE (xalatu (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'xalatu') ALLOCATE (xalatv (jpanv), STAT=ierr) ; CALL chk_allo (ierr, 'xalatv') ALLOCATE (xasrft (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'xasrft') ALLOCATE (xasrfu (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'xasrfu') ALLOCATE (xasrfv (jpanv), STAT=ierr) ; CALL chk_allo (ierr, 'xasrfv') ! ALLOCATE (nborda (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'nborda') ALLOCATE (nbordo (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'nbordo') ! ALLOCATE (wo2a (jpo2a,jpan), STAT=ierr) ; CALL chk_allo (ierr, 'wo2a') ALLOCATE (ko2a (jpo2a,jpan), STAT=ierr) ; CALL chk_allo (ierr, 'ko2a') ALLOCATE (wa2o (jpa2o,jpon), STAT=ierr) ; CALL chk_allo (ierr, 'wa2o') ALLOCATE (ka2o (jpa2o,jpon), STAT=ierr) ; CALL chk_allo (ierr, 'ka2o') ALLOCATE (wasum (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'wasum') ALLOCATE (wosum (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'wosum') ! ALLOCATE (nvo (jpon), STAT=ierr) ; CALL chk_allo (ierr, 'nvo') ALLOCATE (nva (jpan), STAT=ierr) ; CALL chk_allo (ierr, 'nva') ! ALLOCATE (iomskt (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'iomskt') ALLOCATE (iomsku (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'iomsku') ALLOCATE (iomskv (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'iomskv') ALLOCATE (iomskf (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'iomskf') ALLOCATE (iamskt (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'iamskt') ALLOCATE (iamsku (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'iamsku') ALLOCATE (iamskv (jpanv), STAT=ierr) ; CALL chk_allo (ierr, 'iamskv') ALLOCATE (iomskp (jpon) , STAT=ierr) ; CALL chk_allo (ierr, 'iomskp') ALLOCATE (iamskp (jpan) , STAT=ierr) ; CALL chk_allo (ierr, 'iamskp') ! ALLOCATE (xo_ed (jpon, jpoe), STAT=ierr) ; CALL chk_allo (ierr, 'xo_ed') ALLOCATE (yo_ed (jpon, jpoe), STAT=ierr) ; CALL chk_allo (ierr, 'yo_ed') ALLOCATE (xa_ed (jpan, jpae), STAT=ierr) ; CALL chk_allo (ierr, 'xa_ed') ALLOCATE (ya_ed (jpan, jpae), STAT=ierr) ; CALL chk_allo (ierr, 'ya_ed') ! ALLOCATE (o2amask (jpan), STAT=ierr) ; CALL chk_allo (ierr, 'o2amask') ALLOCATE (a2omask (jpon), STAT=ierr) ; CALL chk_allo (ierr, 'a2omask') ALLOCATE (o2afull (jpan), STAT=ierr) ; CALL chk_allo (ierr, 'o2afull') ALLOCATE (a2ofull (jpon), STAT=ierr) ; CALL chk_allo (ierr, 'a2ofull') ALLOCATE (o2amask_i_int (jpan), STAT=ierr) ; CALL chk_allo (ierr, 'o2amask_i_int') ALLOCATE (o2amask_i_ext (jpan), STAT=ierr) ; CALL chk_allo (ierr, 'o2amask_i_ext') ALLOCATE (a2omask_i_int (jpon), STAT=ierr) ; CALL chk_allo (ierr, 'a2omask_i_int') ALLOCATE (a2omask_i_ext (jpon), STAT=ierr) ; CALL chk_allo (ierr, 'a2omask_i_ext') ! ! ---------------------------------------------------------------------------- ALLOCATE (m2ai (0:jpan), STAT=ierr) ; CALL chk_allo (ierr, 'm2ai') ALLOCATE (m2aj (0:jpan), STAT=ierr) ; CALL chk_allo (ierr, 'm2aj') ALLOCATE (mai (0:jpan), STAT=ierr) ; CALL chk_allo (ierr, 'mai ') ALLOCATE (maj (0:jpan), STAT=ierr) ; CALL chk_allo (ierr, 'maj ') m2ai (0) = 0_il ; m2aj (0) = 0_il DO ja = 1, jpan jai = MOD (ja - 1_il, jpai) + 1_il jaj = (ja - 1_il) / jpai + 1_il m2ai (ja) = jai m2aj (ja) = jaj mai (ja) = jai maj (ja) = MAX (1_il, MIN (jaj, jpaj)) IF (la_pole) THEN IF (jai == -1_il ) mai (ja) = jpai-1_il IF (jai == 0_il ) mai (ja) = jpai IF (jai == jpai+1_il) mai (ja) = 1_il IF (jai == jpai+2_il) mai (ja) = 2_il END IF END DO ! ---------------------------------------------------------------------------- ALLOCATE (m2oi (0:jpon), STAT=ierr) ; CALL chk_allo (ierr, 'm2oi') ALLOCATE (m2oj (0:jpon), STAT=ierr) ; CALL chk_allo (ierr, 'm2oj') ALLOCATE (moi (0:jpon), STAT=ierr) ; CALL chk_allo (ierr, 'moi ') ALLOCATE (moj (0:jpon), STAT=ierr) ; CALL chk_allo (ierr, 'moj ') m2oi (0) = 0_il ; m2oj (0) = 0_il moi (0) = 0_il ; moj (0) = 0_il DO jo = 1, jpon joi = MOD (jo - 1_il, jpoi) + 1_il joj = (jo - 1_il) / jpoi + 1_il m2oi (jo) = joi m2oj (jo) = joj moi (jo) = joi moj (jo) = MAX (1_il, MIN (joj, jpoj)) IF (noperio == 1 .OR. noperio == 4 .OR. noperio == -4_il) THEN IF (joi == -1_il ) moi (jo) = jpoi-3_il IF (joi == 0_il ) moi (jo) = jpoi-2_il IF (joi == 1_il ) moi (jo) = jpoi-1_il IF (joi == jpoi ) moi (jo) = 2_il IF (joi == jpoi+1_il) moi (jo) = 3_il IF (joi == jpoi+2_il) moi (jo) = 4_il ENDIF END DO ! ---------------------------------------------------------------------------- ALLOCATE (m1a (jpai, jpaj), STAT=ierr) ; CALL chk_allo (ierr, 'm1a ') ALLOCATE (m1ar (jpai, jpaj), STAT=ierr) ; CALL chk_allo (ierr, 'm1ar') DO jaj = 1, jpaj DO jai = 1, jpai m1a (jai, jaj) = jai + (jaj - 1_il) * jpai END DO END DO DO jaj = 1, jpaj DO jai = 1, jpai ja = m1a (jai, jaj) m1a (jai, jaj) = m1a (mai (ja), maj (ja)) END DO END DO ! ---------------------------------------------------------------------------- ALLOCATE (m1o (jpoi, jpoj), STAT=ierr) ; CALL chk_allo (ierr, 'm1o ') ALLOCATE (m1or (jpoi, jpoj), STAT=ierr) ; CALL chk_allo (ierr, 'm1or') DO joj = 1, jpoj DO joi = 1, jpoi m1o (joi, joj) = joi + (joj - 1_il) * jpoi END DO END DO DO joj = 1, jpoj DO joi = 1, jpoi jo = m1o (joi, joj) m1or (joi, joj) = m1o (moi (jo), moj (jo)) END DO END DO ! ---------------------------------------------------------------------------- !-$$ WRITE (nout,*) 'mai' !-$$ CALL prihin ( RESHAPE(mai (1:jpan), (/jpai, jpaj/)), kscale=3 ) !-$$ WRITE (nout,*) 'maj' !-$$ CALL prihin ( RESHAPE(maj (1:jpan), (/jpai, jpaj/)), kscale=3 ) !-$$ WRITE (nout,*) 'm2ai' !-$$ CALL prihin ( RESHAPE(m2ai(1:jpan), (/jpai, jpaj/)), kscale=3 ) !-$$ WRITE (nout,*) 'm2aj' !-$$ CALL prihin ( RESHAPE(m2aj(1:jpan), (/jpai, jpaj/)), kscale=3 ) !-$$ WRITE (nout,*) 'm1a' !-$$ CALL prihin (m1a , kscale=5) !-$$ WRITE (nout,*) 'm1ar' !-$$ CALL prihin (m1ar, kscale=5) !-$$ STOP END SUBROUTINE alloc_modeles END MODULE modeles