Ignore:
Timestamp:
2018-09-05T15:33:44+02:00 (2 years ago)
Author:
rblod
Message:

update AGRIF library

Location:
vendors/AGRIF/CMEMS_2020/AGRIF_FILES
Files:
6 added
19 edited

Legend:

Unmodified
Added
Removed
  • vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modarrays.F90

    r5656 r10087  
    5555                               proc_id,         & 
    5656                               coords,          & 
    57                                lb_tab_true, ub_tab_true, memberin ) 
     57                               lb_tab_true, ub_tab_true, memberin,  & 
     58                               indminglob3,indmaxglob3) 
    5859!--------------------------------------------------------------------------------------------------- 
    5960    integer,                   intent(in)  :: nbdim         !< Number of dimensions 
     
    6162    integer, dimension(nbdim), intent(in)  :: ub_var        !< Local upper boundary on the current processor 
    6263    integer, dimension(nbdim), intent(in)  :: lb_tab        !< Global lower boundary of the variable 
     64    integer, dimension(nbdim),OPTIONAL     :: indminglob3,indmaxglob3 !< True bounds for MPI USE 
    6365    integer, dimension(nbdim), intent(in)  :: ub_tab        !< Global upper boundary of the variable 
    6466    integer,                   intent(in)  :: proc_id       !< Current processor 
     
    7880        call Agrif_InvLoc( lb_var(i), proc_id, coord_i, lb_glob_index ) 
    7981        call Agrif_InvLoc( ub_var(i), proc_id, coord_i, ub_glob_index ) 
     82        if (present(indminglob3)) then 
     83          indminglob3(i)=lb_glob_index 
     84          indmaxglob3(i)=ub_glob_index 
     85        endif 
    8086#else 
    8187        lb_glob_index = lb_var(i) 
    8288        ub_glob_index = ub_var(i) 
    8389#endif 
     90 
    8491        lb_tab_true(i) = max(lb_tab(i), lb_glob_index) 
    8592        ub_tab_true(i) = min(ub_tab(i), ub_glob_index) 
     93 
    8694    enddo 
    8795! 
     
    123131! 
    124132    iminmaxg(1:nbdim,2) = - iminmaxg(1:nbdim,2) 
    125     call MPI_ALLREDUCE(iminmaxg, lubglob, 2*nbdim, MPI_INTEGER, MPI_MIN, Agrif_mpi_comm, code) 
     133    call MPI_ALLREDUCE(iminmaxg, lubglob, 2*nbdim, MPI_INTEGER, MPI_MIN, & 
     134                       Agrif_mpi_comm, code) 
    126135    lubglob(1:nbdim,2)  = - lubglob(1:nbdim,2) 
    127136#endif 
     
    225234    case (1) ; call Agrif_set_array_tozero_1D(variable%array1) 
    226235    case (2) ; call Agrif_set_array_tozero_2D(variable%array2) 
    227     case (3) ; call Agrif_set_array_tozero_3D(variable%array3) 
     236    case (3) ; call Agrif_set_array_tozero_reshape(variable%array3,size(variable%array3)) 
     237!case (3) ; call Agrif_set_array_tozero_3D(variable%array3) 
    228238    case (4) ; call Agrif_set_array_tozero_4D(variable%array4) 
    229239    case (5) ; call Agrif_set_array_tozero_5D(variable%array5) 
     
    266276!=================================================================================================== 
    267277! 
     278!=================================================================================================== 
     279! 
     280!=================================================================================================== 
     281!  subroutine agrif_set_array_cond 
     282! 
     283!> Compute the masking of \b variablein, according to the required dimension. 
     284!--------------------------------------------------------------------------------------------------- 
     285subroutine agrif_set_array_cond ( variablein, variableout, value, nbdim ) 
     286!--------------------------------------------------------------------------------------------------- 
     287    type(Agrif_Variable), intent(in)    :: variablein     !< Variablein 
     288    type(Agrif_Variable), intent(inout) :: variableout    !< Variableout 
     289    real,intent(in) :: value                            !< special value 
     290    integer, intent(in)                 :: nbdim        !< Dimension of the array 
     291 
     292! 
     293    select case (nbdim) 
     294    case (1) ; call agrif_set_array_cond_1D(variablein%array1,variableout%array1,value) 
     295    case (2) ; call agrif_set_array_cond_2D(variablein%array2,variableout%array2,value) 
     296    case (3) ; call agrif_set_array_cond_reshape(variablein%array3,variableout%array3,value,size(variablein%array3)) 
     297!    case (3) ; call agrif_set_array_cond_3D(variablein%array3,variableout%array3,value) 
     298    case (4) ; call agrif_set_array_cond_4D(variablein%array4,variableout%array4,value) 
     299    case (5) ; call agrif_set_array_cond_5D(variablein%array5,variableout%array5,value) 
     300    case (6) ; call agrif_set_array_cond_6D(variablein%array6,variableout%array6,value) 
     301    end select 
     302!--------------------------------------------------------------------------------------------------- 
     303contains 
     304!--------------------------------------------------------------------------------------------------- 
     305subroutine agrif_set_array_cond_1D(arrayin,arrayout,value) 
     306real,dimension(:),intent(in) :: arrayin 
     307real,dimension(:),intent(out) :: arrayout 
     308real :: value 
     309 
     310where (arrayin == value) 
     311  arrayout = 0. 
     312elsewhere 
     313  arrayout = 1. 
     314end where 
     315 
     316end subroutine agrif_set_array_cond_1D 
     317! 
     318subroutine agrif_set_array_cond_2D(arrayin,arrayout,value) 
     319real,dimension(:,:),intent(in) :: arrayin 
     320real,dimension(:,:),intent(out) :: arrayout 
     321real :: value 
     322 
     323where (arrayin == value) 
     324  arrayout = 0. 
     325elsewhere 
     326  arrayout = 1. 
     327end where 
     328 
     329end subroutine agrif_set_array_cond_2D 
     330! 
     331subroutine agrif_set_array_cond_3D(arrayin,arrayout,value) 
     332real,dimension(:,:,:),intent(in) :: arrayin 
     333real,dimension(:,:,:),intent(out) :: arrayout 
     334real :: value 
     335 
     336where (arrayin == value) 
     337  arrayout = 0. 
     338elsewhere 
     339  arrayout = 1. 
     340end where 
     341 
     342end subroutine agrif_set_array_cond_3D 
     343! 
     344subroutine agrif_set_array_cond_4D(arrayin,arrayout,value) 
     345real,dimension(:,:,:,:),intent(in) :: arrayin 
     346real,dimension(:,:,:,:),intent(out) :: arrayout 
     347real :: value 
     348 
     349where (arrayin == value) 
     350  arrayout = 0. 
     351elsewhere 
     352  arrayout = 1. 
     353end where 
     354 
     355end subroutine agrif_set_array_cond_4D 
     356! 
     357subroutine agrif_set_array_cond_5D(arrayin,arrayout,value) 
     358real,dimension(:,:,:,:,:),intent(in) :: arrayin 
     359real,dimension(:,:,:,:,:),intent(out) :: arrayout 
     360real :: value 
     361 
     362where (arrayin == value) 
     363  arrayout = 0. 
     364elsewhere 
     365  arrayout = 1. 
     366end where 
     367 
     368end subroutine agrif_set_array_cond_5D 
     369! 
     370subroutine agrif_set_array_cond_6D(arrayin,arrayout,value) 
     371real,dimension(:,:,:,:,:,:),intent(in) :: arrayin 
     372real,dimension(:,:,:,:,:,:),intent(out) :: arrayout 
     373real :: value 
     374 
     375where (arrayin == value) 
     376  arrayout = 0. 
     377elsewhere 
     378  arrayout = 1. 
     379end where 
     380 
     381end subroutine agrif_set_array_cond_6D 
     382!--------------------------------------------------------------------------------------------------- 
     383end subroutine agrif_set_array_cond 
    268384!=================================================================================================== 
    269385!  subroutine Agrif_var_copy_array 
     
    330446        real, dimension(l(1):,l(2):,l(3):), intent(out) :: tabout 
    331447        real, dimension(m(1):,m(2):,m(3):), intent(in)  :: tabin 
    332         tabout(inf1(1):sup1(1), & 
    333                inf1(2):sup1(2), & 
    334                inf1(3):sup1(3)) = tabin(inf2(1):sup2(1), & 
    335                                         inf2(2):sup2(2), & 
    336                                         inf2(3):sup2(3)) 
     448        integer :: i,j,k 
     449 
     450 
     451!$OMP PARALLEL DO DEFAULT(none) PRIVATE(i,j,k) & 
     452!$OMP SHARED(inf1,inf2,sup1,sup2,tabin,tabout) & 
     453!$OMP SCHEDULE(RUNTIME) 
     454        do k=inf1(3),sup1(3) 
     455        do j=inf1(2),sup1(2) 
     456        do i=inf1(1),sup1(1) 
     457!          tabout(i,j,k) = tabin(i+inf2(1)-inf1(1),j+inf2(2)-inf1(2),k+inf2(3)-inf1(3)) 
     458          tabout(i,j,k) = tabin(i,j,k) 
     459        enddo 
     460        enddo 
     461        enddo 
     462!$OMP END PARALLEL DO 
     463 
     464 
     465!        tabout(inf1(1):sup1(1), & 
     466!               inf1(2):sup1(2), & 
     467!               inf1(3):sup1(3)) = tabin(inf2(1):sup2(1), & 
     468!                                        inf2(2):sup2(2), & 
     469!                                        inf2(3):sup2(3)) 
    337470    end subroutine Agrif_copy_array_3d 
    338471! 
     
    631764    integer, dimension(6), intent(out)          :: lb_child     !< Lower bound on the child grid 
    632765    integer, dimension(6), intent(out)          :: lb_parent    !< Lower bound on the parent grid 
    633     real, dimension(6),    intent(out)          :: s_child      !< Child  grid position (s_root = 0) 
    634     real, dimension(6),    intent(out)          :: s_parent     !< Parent grid position (s_root = 0) 
    635     real, dimension(6),    intent(out)          :: ds_child     !< Child  grid dx (ds_root = 1) 
    636     real, dimension(6),    intent(out)          :: ds_parent    !< Parent grid dx (ds_root = 1) 
     766    real(kind=8), dimension(6),    intent(out)  :: s_child      !< Child  grid position (s_root = 0) 
     767    real(kind=8), dimension(6),    intent(out)  :: s_parent     !< Parent grid position (s_root = 0) 
     768    real(kind=8), dimension(6),    intent(out)  :: ds_child     !< Child  grid dx (ds_root = 1) 
     769    real(kind=8), dimension(6),    intent(out)  :: ds_parent    !< Parent grid dx (ds_root = 1) 
    637770    integer,               intent(out)          :: nbdim        !< Number of dimensions 
    638771    logical,               intent(in)           :: interp       !< .true. if preprocess for interpolation, \n 
     
    671804            else 
    672805                ub_child(n) = lb_child(n) + Agrif_Child_Gr % nb(1) - 1 
    673                 s_child(n)  = s_child(n)  + 0.5*ds_child(n) 
    674                 s_parent(n) = s_parent(n) + 0.5*ds_parent(n) 
     806                s_child(n)  = s_child(n)  + 0.5d0*ds_child(n) 
     807                s_parent(n) = s_parent(n) + 0.5d0*ds_parent(n) 
    675808            endif 
    676809! 
     
    689822            else 
    690823                ub_child(n) = lb_child(n) + Agrif_Child_Gr % nb(2) - 1 
    691                 s_child(n)  = s_child(n)  + 0.5*ds_child(n) 
    692                 s_parent(n) = s_parent(n) + 0.5*ds_parent(n) 
     824                s_child(n)  = s_child(n)  + 0.5d0*ds_child(n) 
     825                s_parent(n) = s_parent(n) + 0.5d0*ds_parent(n) 
    693826            endif 
    694827! 
     
    727860!           No interpolation but only a copy of the values of the grid variable 
    728861            lb_parent(n) = lb_child(n) 
    729             s_child(n)   = 0. 
    730             s_parent(n)  = 0. 
    731             ds_child(n)  = 1. 
    732             ds_parent(n) = 1. 
     862            s_child(n)   = 0.d0 
     863            s_parent(n)  = 0.d0 
     864            ds_child(n)  = 1.d0 
     865            ds_parent(n) = 1.d0 
    733866! 
    734867        end select 
     
    803936    do i = 1,nbdim 
    804937! 
     938     if (coords(i) == 0) then 
     939       nbloc(i) = 1 
     940       locbounds(i,1,1) = lb_glob(i) 
     941       locbounds(i,2,1) = ub_glob(i) 
     942       locbounds(i,1,2) = lb_glob(i) 
     943       locbounds(i,2,2) = ub_glob(i) 
     944     else 
    805945        call Agrif_InvLoc(lb_var(i), rank, coords(i), i1) 
    806946! 
     
    816956            endif 
    817957        enddo 
     958     endif 
    818959    enddo 
    819960 
     
    825966! 
    826967end module Agrif_Arrays 
     968 
     969 
     970subroutine agrif_set_array_cond_reshape(arrayin,arrayout,value,n) 
     971integer :: n 
     972real,dimension(n) :: arrayin,arrayout 
     973real :: value 
     974 
     975integer :: i 
     976 
     977do i=1,n 
     978  if (arrayin(i) == value) then 
     979    arrayout(i) = 0. 
     980  else 
     981    arrayout(i) = 1. 
     982  endif 
     983enddo 
     984 
     985end subroutine agrif_set_array_cond_reshape 
     986 
     987subroutine agrif_set_array_tozero_reshape(array,n) 
     988integer :: n 
     989real,dimension(n) :: array 
     990 
     991integer :: i 
     992 
     993!$OMP PARALLEL DO DEFAULT(none) PRIVATE(i) & 
     994!$OMP SHARED(array,n) 
     995do i=1,n 
     996    array(i) = 0. 
     997enddo 
     998!$OMP END PARALLEL DO 
     999 
     1000end subroutine agrif_set_array_tozero_reshape 
  • vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modbc.F90

    r5656 r10087  
    3232! 
    3333    implicit none 
     34    REAL,DIMENSION(:),ALLOCATABLE :: parray_temp 
    3435! 
    3536contains 
     
    6162    integer, dimension(6)  :: loctab_child      ! Indicates if the child grid has a common border 
    6263                                                !    with the root grid 
    63     real, dimension(6)     :: s_child, s_parent   ! Positions of the parent and child grids 
    64     real, dimension(6)     :: ds_child, ds_parent ! Space steps of the parent and child grids 
     64    real(kind=8), dimension(6)     :: s_child, s_parent   ! Positions of the parent and child grids 
     65    real(kind=8), dimension(6)     :: ds_child, ds_parent ! Space steps of the parent and child grids 
    6566! 
    6667    call PreProcessToInterpOrUpdate( parent,   child,       & 
     
    145146    INTEGER, DIMENSION(nbdim)   :: posvartab_Child      !< Position of the grid variable (1 or 2) 
    146147    INTEGER, DIMENSION(nbdim)   :: loctab_Child         !< Indicates if the child grid has a common border with the root grid 
    147     REAL   , DIMENSION(nbdim)   :: s_Child,  s_Parent   !< Positions of the parent and child grids 
    148     REAL   , DIMENSION(nbdim)   :: ds_Child, ds_Parent  !< Space steps of the parent and child grids 
     148    REAL(kind=8)   , DIMENSION(nbdim)   :: s_Child,  s_Parent   !< Positions of the parent and child grids 
     149    REAL(kind=8)   , DIMENSION(nbdim)   :: ds_Child, ds_Parent  !< Space steps of the parent and child grids 
    149150    INTEGER                             :: nbdim        !< Number of dimensions of the grid variable 
    150151    procedure()                         :: procname     !< Data recovery procedure 
     
    159160    INTEGER,DIMENSION(nbdim,2,2,nbdim)  :: ptres,ptres2 ! calculated 
    160161    INTEGER,DIMENSION(nbdim)            :: coords 
    161     INTEGER                             :: i, nb, ndir 
     162    INTEGER                             :: i, nb, ndir,j,k,l 
    162163    INTEGER                             :: n, sizetab 
    163164    INTEGER                             :: ibeg, iend 
    164165    INTEGER                             :: i1,i2,j1,j2,k1,k2,l1,l2,m1,m2,n1,n2 
    165166    REAL                                :: c1t,c2t      ! Coefficients for the time interpolation (c2t=1-c1t) 
     167    INTEGER :: isize 
     168    INTEGER :: kindex_2d(2,nbdim) 
     169 
    166170#if defined AGRIF_MPI 
    167171! 
     
    188192    END WHERE 
    189193! 
    190     call Agrif_get_var_global_bounds(child,lubglob,nbdim) 
     194!   call Agrif_get_var_global_bounds(child,lubglob,nbdim) 
     195    lubglob = child%lubglob(1:nbdim,:) 
    191196! 
    192197    indtruetab(1:nbdim,1,1) = max(indtab(1:nbdim,1,1), lubglob(1:nbdim,1)) 
     
    194199    indtruetab(1:nbdim,2,1) = min(indtab(1:nbdim,2,1), lubglob(1:nbdim,2)) 
    195200    indtruetab(1:nbdim,2,2) = min(indtab(1:nbdim,2,2), lubglob(1:nbdim,2)) 
     201    
    196202! 
    197203    do nb = 1,nbdim 
     
    267273                if (loctab_child(nb) /= (-ndir) .AND. loctab_child(nb) /= -3) then 
    268274! 
     275 
    269276                    call Agrif_InterpnD(type_interp, parent, child,             & 
    270277                                        ptres(1:nbdim,1,ndir,nb),               & 
     
    319326        do nb = 1,nbdim 
    320327            do ndir = 1,2 
    321                 if (loctab_child(nb) /= (-ndir) .AND. loctab_child(nb) /= -3) then 
     328                kindex_2d(ndir,nb) = kindex 
     329                if ( (loctab_child(nb) /= (-ndir)) .AND. (loctab_child(nb) /= -3) .AND. child%memberin(nb,ndir) ) then 
    322330                    Call timeInterpolation(child,ptres2(:,:,ndir,nb),kindex,c1t,c2t,nbdim) 
    323331                endif 
     
    325333        enddo 
    326334! 
    327     endif 
    328 ! 
    329335    do nb = 1,nbdim 
    330336    do ndir = 1,2 
    331337        if ( (loctab_child(nb) /= (-ndir)) .AND. (loctab_child(nb) /= -3) .AND. child%memberin(nb,ndir) ) then 
     338 
     339         do i=1,nbdim 
     340         if (ptres2(i,1,ndir,nb) /= child%childarray(i,1,2,nb,ndir)) then 
     341            print *,'problem ptres2 childarray 1 ',ptres2(i,1,ndir,nb) /= child%childarray(i,1,2,nb,ndir) 
     342            stop 
     343         endif 
     344         if (ptres2(i,2,ndir,nb) /= child%childarray(i,2,2,nb,ndir)) then 
     345            print *,'problem ptres2 childarray 2 ',ptres2(i,2,ndir,nb) /= child%childarray(i,2,2,nb,ndir) 
     346          stop 
     347         endif 
     348         enddo 
     349 
    332350            select case(nbdim) 
    333351            case(1) 
     
    346364                              i1,i2,j1,j2, .FALSE.,coords(nb),ndir) 
    347365            case(3) 
     366 
    348367                i1 = child % childarray(1,1,2,nb,ndir) 
    349368                i2 = child % childarray(1,2,2,nb,ndir) 
     
    353372                k2 = child % childarray(3,2,2,nb,ndir) 
    354373 
    355                 call procname(parray3(i1:i2,j1:j2,k1:k2),                   & 
    356                               i1,i2,j1,j2,k1,k2, .FALSE.,coords(nb),ndir) 
     374               call procname(parray_temp(kindex_2d(ndir,nb)),i1,i2,j1,j2,k1,k2, .FALSE.,coords(nb),ndir) 
     375 
    357376            case(4) 
    358377                i1 = child % childarray(1,1,2,nb,ndir) 
     
    365384                l2 = child % childarray(4,2,2,nb,ndir) 
    366385 
    367                 call procname(parray4(i1:i2,j1:j2,k1:k2,l1:l2),             & 
    368                               i1,i2,j1,j2,k1,k2,l1,l2, .FALSE.,coords(nb),ndir) 
     386                call procname(parray_temp(kindex_2d(ndir,nb)),i1,i2,j1,j2,k1,k2,l1,l2,.FALSE.,coords(nb),ndir) 
     387 
    369388            case(5) 
    370389                i1 = child % childarray(1,1,2,nb,ndir) 
     
    401420    enddo 
    402421    enddo 
     422 
     423    else 
     424 
     425    do nb = 1,nbdim 
     426    do ndir = 1,2 
     427        if ( (loctab_child(nb) /= (-ndir)) .AND. (loctab_child(nb) /= -3) .AND. child%memberin(nb,ndir) ) then 
     428            select case(nbdim) 
     429            case(1) 
     430                i1 = child % childarray(1,1,2,nb,ndir) 
     431                i2 = child % childarray(1,2,2,nb,ndir) 
     432 
     433                call procname(parray1(i1:i2),                               & 
     434                              i1,i2, .FALSE.,coords(nb),ndir) 
     435            case(2) 
     436                i1 = child % childarray(1,1,2,nb,ndir) 
     437                i2 = child % childarray(1,2,2,nb,ndir) 
     438                j1 = child % childarray(2,1,2,nb,ndir) 
     439                j2 = child % childarray(2,2,2,nb,ndir) 
     440 
     441                call procname(parray2(i1:i2,j1:j2),                         & 
     442                              i1,i2,j1,j2, .FALSE.,coords(nb),ndir) 
     443            case(3) 
     444 
     445                i1 = child % childarray(1,1,2,nb,ndir) 
     446                i2 = child % childarray(1,2,2,nb,ndir) 
     447                j1 = child % childarray(2,1,2,nb,ndir) 
     448                j2 = child % childarray(2,2,2,nb,ndir) 
     449                k1 = child % childarray(3,1,2,nb,ndir) 
     450                k2 = child % childarray(3,2,2,nb,ndir) 
     451 
     452                call procname(parray3(i1:i2,j1:j2,k1:k2),                   & 
     453                              i1,i2,j1,j2,k1,k2, .FALSE.,coords(nb),ndir) 
     454 
     455            case(4) 
     456                i1 = child % childarray(1,1,2,nb,ndir) 
     457                i2 = child % childarray(1,2,2,nb,ndir) 
     458                j1 = child % childarray(2,1,2,nb,ndir) 
     459                j2 = child % childarray(2,2,2,nb,ndir) 
     460                k1 = child % childarray(3,1,2,nb,ndir) 
     461                k2 = child % childarray(3,2,2,nb,ndir) 
     462                l1 = child % childarray(4,1,2,nb,ndir) 
     463                l2 = child % childarray(4,2,2,nb,ndir) 
     464 
     465                call procname(parray4(i1:i2,j1:j2,k1:k2,l1:l2),             & 
     466                              i1,i2,j1,j2,k1,k2,l1,l2, .FALSE.,coords(nb),ndir) 
     467 
     468            case(5) 
     469                i1 = child % childarray(1,1,2,nb,ndir) 
     470                i2 = child % childarray(1,2,2,nb,ndir) 
     471                j1 = child % childarray(2,1,2,nb,ndir) 
     472                j2 = child % childarray(2,2,2,nb,ndir) 
     473                k1 = child % childarray(3,1,2,nb,ndir) 
     474                k2 = child % childarray(3,2,2,nb,ndir) 
     475                l1 = child % childarray(4,1,2,nb,ndir) 
     476                l2 = child % childarray(4,2,2,nb,ndir) 
     477                m1 = child % childarray(5,1,2,nb,ndir) 
     478                m2 = child % childarray(5,2,2,nb,ndir) 
     479 
     480                call procname(parray5(i1:i2,j1:j2,k1:k2,l1:l2,m1:m2),       & 
     481                              i1,i2,j1,j2,k1,k2,l1,l2,m1,m2, .FALSE.,coords(nb),ndir) 
     482            case(6) 
     483                i1 = child % childarray(1,1,2,nb,ndir) 
     484                i2 = child % childarray(1,2,2,nb,ndir) 
     485                j1 = child % childarray(2,1,2,nb,ndir) 
     486                j2 = child % childarray(2,2,2,nb,ndir) 
     487                k1 = child % childarray(3,1,2,nb,ndir) 
     488                k2 = child % childarray(3,2,2,nb,ndir) 
     489                l1 = child % childarray(4,1,2,nb,ndir) 
     490                l2 = child % childarray(4,2,2,nb,ndir) 
     491                m1 = child % childarray(5,1,2,nb,ndir) 
     492                m2 = child % childarray(5,2,2,nb,ndir) 
     493                n1 = child % childarray(6,1,2,nb,ndir) 
     494                n2 = child % childarray(6,2,2,nb,ndir) 
     495 
     496                call procname(parray6(i1:i2,j1:j2,k1:k2,l1:l2,m1:m2,n1:n2), & 
     497                              i1,i2,j1,j2,k1,k2,l1,l2,m1,m2,n1,n2, .FALSE.,coords(nb),ndir) 
     498            end select 
     499        endif 
     500    enddo 
     501    enddo 
     502 
     503    endif 
     504! 
     505 
    403506!--------------------------------------------------------------------------------------------------- 
    404507end subroutine Agrif_Correctnd 
     
    525628! 
    526629    INTEGER :: ir,jr,kr,lr,mr,nr 
     630    INTEGER :: kindexmax, isize,i 
     631    REAL,DIMENSION(:),ALLOCATABLE :: tabtemp 
     632 
     633    isize = 1 
     634    DO i=1,nbdim 
     635      isize = isize * (bounds(i,2)-bounds(i,1)+1) 
     636    ENDDO 
     637    IF (isize <= 0) RETURN 
     638 
     639    kindexmax = kindex + isize - 1 
     640    IF (.NOT.ALLOCATED(parray_temp)) THEN 
     641      ALLOCATE(parray_temp(kindexmax))  
     642    ELSE  
     643      IF (size(parray_temp) < kindexmax) THEN 
     644         ALLOCATE(tabtemp(size(parray_temp))) 
     645         tabtemp = parray_temp 
     646         DEALLOCATE(parray_temp) 
     647         ALLOCATE(parray_temp(kindexmax)) 
     648         parray_temp(1:size(tabtemp)) = tabtemp 
     649         DEALLOCATE(tabtemp) 
     650      ENDIF 
     651    ENDIF 
     652  
    527653! 
    528654    SELECT CASE (nbdim) 
     
    546672! 
    547673    CASE (3) 
    548         do kr = bounds(3,1),bounds(3,2) 
    549         do jr = bounds(2,1),bounds(2,2) 
    550 !CDIR ALTCODE 
    551         do ir = bounds(1,1),bounds(1,2) 
    552             parray3(ir,jr,kr) = c2t*child_var % oldvalues2d(1,kindex) + & 
    553                                             c1t*child_var % oldvalues2d(2,kindex) 
    554             kindex = kindex + 1 
    555         enddo 
    556         enddo 
    557         enddo 
     674 
     675        parray_temp(kindex:kindexmax) = c2t*child_var % oldvalues2d(1,kindex:kindexmax) + & 
     676                                        c1t*child_var % oldvalues2d(2,kindex:kindexmax) 
     677 
    558678! 
    559679    CASE (4) 
    560         do lr = bounds(4,1),bounds(4,2) 
    561         do kr = bounds(3,1),bounds(3,2) 
    562         do jr = bounds(2,1),bounds(2,2) 
    563 !CDIR ALTCODE 
    564         do ir = bounds(1,1),bounds(1,2) 
    565             parray4(ir,jr,kr,lr) = c2t*child_var % oldvalues2d(1,kindex) + & 
    566                                                c1t*child_var % oldvalues2d(2,kindex) 
    567             kindex = kindex + 1 
    568         enddo 
    569         enddo 
    570         enddo 
    571         enddo 
     680 
     681        parray_temp(kindex:kindexmax) = c2t*child_var % oldvalues2d(1,kindex:kindexmax) + & 
     682                                        c1t*child_var % oldvalues2d(2,kindex:kindexmax) 
     683 
    572684! 
    573685    CASE (5) 
     
    605717        enddo 
    606718    END SELECT 
     719 
     720    kindex = kindexmax + 1 
     721 
    607722!--------------------------------------------------------------------------------------------------- 
    608723end subroutine timeInterpolation 
  • vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modbcfunction.F90

    r5656 r10087  
    2121!     Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 
    2222! 
     23!--------------------------------------------------------------------------------------------------- 
    2324!> Module Agrif_BcFunction. 
    24 ! 
     25!! 
     26!--------------------------------------------------------------------------------------------------- 
    2527module Agrif_BcFunction 
    2628! 
    2729!     Modules used: 
    2830! 
    29     use Agrif_Boundary 
    30     use Agrif_Update 
    31     use Agrif_Save 
     31   use Agrif_User_Variables 
     32 
    3233! 
    3334    implicit none 
    34 ! 
    35     interface Agrif_Set_Parent 
    36         module procedure Agrif_Set_Parent_int,      & 
    37                          Agrif_Set_Parent_real4,    & 
    38                          Agrif_Set_Parent_real8 
    39     end interface 
    4035! 
    4136    interface Agrif_Save_Forrestore 
     
    4742! 
    4843contains 
    49 ! 
    50 !=================================================================================================== 
    51 !  subroutine Agrif_Set_parent_int 
    52 ! 
    53 !> To set the TYPE of the variable 
    54 !--------------------------------------------------------------------------------------------------- 
    55 subroutine Agrif_Set_parent_int(tabvarsindic,value) 
    56 !--------------------------------------------------------------------------------------------------- 
    57     integer, intent(in)     :: tabvarsindic !< indice of the variable in tabvars 
    58     integer, intent(in)     :: value        !< input value 
    59 ! 
    60     Agrif_Curgrid % parent % tabvars_i(tabvarsindic) % iarray0 = value 
    61 !--------------------------------------------------------------------------------------------------- 
    62 end subroutine Agrif_Set_parent_int 
    63 !=================================================================================================== 
    64 ! 
    65 !=================================================================================================== 
    66 !  subroutine Agrif_Set_parent_real4 
    67 !--------------------------------------------------------------------------------------------------- 
    68 !> To set the TYPE of the variable 
    69 !--------------------------------------------------------------------------------------------------- 
    70 subroutine Agrif_Set_parent_real4 ( tabvarsindic, value ) 
    71 !--------------------------------------------------------------------------------------------------- 
    72     integer, intent(in)     :: tabvarsindic !< indice of the variable in tabvars 
    73     real(kind=4),intent(in) :: value        !< input value 
    74 ! 
    75     Agrif_Curgrid % parent % tabvars_r(tabvarsindic) % array0 = value 
    76     Agrif_Curgrid % parent % tabvars_r(tabvarsindic) % sarray0 = value 
    77 !--------------------------------------------------------------------------------------------------- 
    78 end subroutine Agrif_Set_parent_real4 
    79 !=================================================================================================== 
    80 ! 
    81 !=================================================================================================== 
    82 !  subroutine Agrif_Set_parent_real8 
    83 !--------------------------------------------------------------------------------------------------- 
    84 !> To set the TYPE of the variable 
    85 !--------------------------------------------------------------------------------------------------- 
    86 subroutine Agrif_Set_parent_real8 ( tabvarsindic, value ) 
    87 !--------------------------------------------------------------------------------------------------- 
    88     integer, intent(in)     :: tabvarsindic !< indice of the variable in tabvars 
    89     real(kind=8),intent(in) :: value        !< input value 
    90 ! 
    91     Agrif_Curgrid % parent % tabvars_r(tabvarsindic) % darray0 = value 
    92 !--------------------------------------------------------------------------------------------------- 
    93 end subroutine Agrif_Set_parent_real8 
    94 !=================================================================================================== 
    95 ! 
    96 !=================================================================================================== 
    97 !  subroutine Agrif_Set_bc 
    98 !--------------------------------------------------------------------------------------------------- 
    99 subroutine Agrif_Set_bc ( tabvarsindic, bcinfsup, Interpolationshouldbemade ) 
    100 !--------------------------------------------------------------------------------------------------- 
    101     integer,               intent(in)   :: tabvarsindic !< indice of the variable in tabvars 
    102     integer, dimension(2), intent(in)   :: bcinfsup     !< bcinfsup 
    103     logical, optional,     intent(in)   :: Interpolationshouldbemade !< interpolation should be made 
    104 ! 
    105     integer                         :: indic ! indice of the variable in tabvars 
    106     type(Agrif_Variable),  pointer  :: var 
    107 ! 
    108     indic = Agrif_Curgrid % tabvars_i(tabvarsindic) % iarray0 
    109 ! 
    110     if (indic <= 0) then 
    111         var => Agrif_Search_Variable(Agrif_Curgrid,-indic) 
    112     else 
    113         print*,"Agrif_Set_bc : warning indic >= 0 !!!" 
    114         var => Agrif_Curgrid % tabvars(indic) 
    115     endif 
    116  
    117     if (.not.associated(var)) return ! Grand mother grid case 
    118 ! 
    119     if ( Agrif_Curgrid % fixedrank /= 0 ) then 
    120         if ( .not.associated(var % oldvalues2D) ) then 
    121             allocate(var % oldvalues2D(2,1)) 
    122             var % interpIndex = -1 
    123             var % oldvalues2D = 0. 
    124         endif 
    125         if ( present(Interpolationshouldbemade) ) then 
    126             var % Interpolationshouldbemade = Interpolationshouldbemade 
    127         endif 
    128     endif 
    129 ! 
    130     var % bcinf = bcinfsup(1) 
    131     var % bcsup = bcinfsup(2) 
    132 !--------------------------------------------------------------------------------------------------- 
    133 end subroutine Agrif_Set_bc 
    134 !=================================================================================================== 
    135 ! 
    136 !=================================================================================================== 
    137 !  subroutine Agrif_Set_interp 
    138 !--------------------------------------------------------------------------------------------------- 
    139 subroutine Agrif_Set_interp ( tabvarsindic, interp, interp1, interp2, interp3 , interp4) 
    140 !--------------------------------------------------------------------------------------------------- 
    141     integer,           intent(in)   :: tabvarsindic !< indice of the variable in tabvars 
    142     integer, optional, intent(in)   :: interp, interp1, interp2, interp3, interp4 
    143 ! 
    144     integer                         :: indic ! indice of the variable in tabvars 
    145     type(Agrif_Variable), pointer   :: var 
    146 ! 
    147     indic = Agrif_Curgrid % tabvars_i(tabvarsindic) % iarray0 
    148 ! 
    149     if (indic <= 0) then 
    150         var => Agrif_Search_Variable(Agrif_Mygrid,-indic) 
    151     else 
    152         print*,"Agrif_Set_interp : warning indic >= 0 !!!" 
    153         var => Agrif_Mygrid % tabvars(indic) 
    154     endif 
    155 ! 
    156     var % type_interp = Agrif_Constant 
    157 ! 
    158     if (present(interp))    var % type_interp    = interp 
    159     if (present(interp1))   var % type_interp(1) = interp1 
    160     if (present(interp2))   var % type_interp(2) = interp2 
    161     if (present(interp3))   var % type_interp(3) = interp3 
    162     if (present(interp4))   var % type_interp(4) = interp4 
    163 !--------------------------------------------------------------------------------------------------- 
    164 end subroutine Agrif_Set_interp 
    165 !=================================================================================================== 
    166 ! 
    167 !=================================================================================================== 
    168 !  subroutine Agrif_Set_bcinterp 
    169 !--------------------------------------------------------------------------------------------------- 
    170 subroutine Agrif_Set_bcinterp ( tabvarsindic, interp,   interp1,  interp2,  interp3, interp4, & 
    171                                               interp11, interp12, interp21, interp22 ) 
    172 !--------------------------------------------------------------------------------------------------- 
    173     INTEGER,           intent(in)   :: tabvarsindic !< indice of the variable in tabvars 
    174     INTEGER, OPTIONAL, intent(in)   :: interp,   interp1,  interp2,  interp3, interp4 
    175     INTEGER, OPTIONAL, intent(in)   :: interp11, interp12, interp21, interp22 
    176 ! 
    177     INTEGER                         :: indic ! indice of the variable in tabvars 
    178     TYPE(Agrif_Variable), pointer   :: var 
    179 ! 
     44 
     45!=================================================================================================== 
     46!  subroutine Agrif_Set_restore 
     47!> This subroutine is used to set the index of the current grid variable we want to restore. 
     48!--------------------------------------------------------------------------------------------------- 
     49subroutine Agrif_Set_restore ( tabvarsindic ) 
     50!--------------------------------------------------------------------------------------------------- 
     51    INTEGER, intent(in) :: tabvarsindic     !< indice of the variable in tabvars 
     52! 
     53    INTEGER :: indic  !  indice of the variable in tabvars 
     54! 
     55print *,'CURRENTLY BROKEN' 
     56STOP 
     57 
    18058    indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0 
    18159! 
    182     if (indic <= 0) then 
    183         var => Agrif_Search_Variable(Agrif_Mygrid,-indic) 
    184     else 
    185         print*,"Agrif_Set_bcinterp : warning indic >= 0 !!!" 
    186         var => Agrif_Mygrid % tabvars(indic) 
    187     endif 
    188 ! 
    189     var % type_interp_bc = Agrif_Constant 
    190 ! 
    191     if (present(interp))    var % type_interp_bc      = interp 
    192     if (present(interp1))   var % type_interp_bc(:,1) = interp1 
    193     if (present(interp11))  var % type_interp_bc(1,1) = interp11 
    194     if (present(interp12))  var % type_interp_bc(1,2) = interp12 
    195     if (present(interp2))   var % type_interp_bc(:,2) = interp2 
    196     if (present(interp21))  var % type_interp_bc(2,1) = interp21 
    197     if (present(interp22))  var % type_interp_bc(2,2) = interp22 
    198     if (present(interp3))   var % type_interp_bc(:,3) = interp3 
    199     if (present(interp4))   var % type_interp_bc(:,4) = interp4 
    200 !--------------------------------------------------------------------------------------------------- 
    201 end subroutine Agrif_Set_bcinterp 
    202 !=================================================================================================== 
    203 ! 
    204 !=================================================================================================== 
    205 !  subroutine Agrif_Set_UpdateType 
    206 !--------------------------------------------------------------------------------------------------- 
    207 subroutine Agrif_Set_UpdateType ( tabvarsindic, update,  update1, update2, & 
    208                                                 update3, update4, update5 ) 
    209 !--------------------------------------------------------------------------------------------------- 
    210     INTEGER,           intent(in) :: tabvarsindic     !< indice of the variable in tabvars 
    211     INTEGER, OPTIONAL, intent(in) :: update, update1, update2, update3, update4, update5 
    212 ! 
    213     INTEGER                         :: indic ! indice of the variable in tabvars 
    214     type(Agrif_Variable),  pointer  :: root_var 
    215 ! 
    216     indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0 
    217 ! 
    218     if (indic <= 0) then 
    219         root_var => Agrif_Search_Variable(Agrif_Mygrid,-indic) 
    220     else 
    221         print*,"Agrif_Set_UpdateType : warning indic >= 0 !!!" 
    222         root_var => Agrif_Mygrid % tabvars(indic) 
    223     endif 
    224 ! 
    225     root_var % type_update = Agrif_Update_Copy 
    226     if (present(update))    root_var % type_update    = update 
    227     if (present(update1))   root_var % type_update(1) = update1 
    228     if (present(update2))   root_var % type_update(2) = update2 
    229     if (present(update3))   root_var % type_update(3) = update3 
    230     if (present(update4))   root_var % type_update(4) = update4 
    231     if (present(update5))   root_var % type_update(5) = update5 
    232 !--------------------------------------------------------------------------------------------------- 
    233 end subroutine Agrif_Set_UpdateType 
    234 !=================================================================================================== 
    235 ! 
    236 !=================================================================================================== 
    237 !  subroutine Agrif_Set_restore 
    238 !--------------------------------------------------------------------------------------------------- 
    239 subroutine Agrif_Set_restore ( tabvarsindic ) 
    240 !--------------------------------------------------------------------------------------------------- 
    241     INTEGER, intent(in) :: tabvarsindic     !< indice of the variable in tabvars 
    242 ! 
    243     INTEGER :: indic  !  indice of the variable in tabvars 
    244 ! 
    245     indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0 
    246 ! 
    24760    Agrif_Mygrid%tabvars(indic) % restore = .TRUE. 
    24861!--------------------------------------------------------------------------------------------------- 
     
    25164! 
    25265!=================================================================================================== 
    253 !  subroutine Agrif_Init_variable 
    254 !--------------------------------------------------------------------------------------------------- 
    255 subroutine Agrif_Init_variable ( tabvarsindic, procname ) 
    256 !--------------------------------------------------------------------------------------------------- 
    257     INTEGER, intent(in)  :: tabvarsindic     !< indice of the variable in tabvars 
    258     procedure()          :: procname         !< Data recovery procedure 
    259 ! 
    260     if ( Agrif_Curgrid%level <= 0 ) return 
    261 ! 
    262     call Agrif_Interp_variable(tabvarsindic, procname) 
    263     call Agrif_Bc_variable(tabvarsindic, procname, 1.) 
    264 !--------------------------------------------------------------------------------------------------- 
    265 end subroutine Agrif_Init_variable 
    266 !=================================================================================================== 
    267 ! 
    268 !=================================================================================================== 
    269 !  subroutine Agrif_Bc_variable 
    270 !--------------------------------------------------------------------------------------------------- 
    271 subroutine Agrif_Bc_variable ( tabvarsindic, procname, calledweight ) 
    272 !--------------------------------------------------------------------------------------------------- 
    273     integer,        intent(in) :: tabvarsindic     !< indice of the variable in tabvars 
    274     procedure()                :: procname 
    275     real, optional, intent(in) :: calledweight 
    276 ! 
    277     real    :: weight 
    278     logical :: pweight 
    279     integer :: indic 
    280     integer :: nbdim 
    281     type(Agrif_Variable), pointer :: root_var 
    282     type(Agrif_Variable), pointer :: parent_var 
    283     type(Agrif_Variable), pointer :: child_var 
    284     type(Agrif_Variable), pointer :: child_tmp      ! Temporary variable on the child grid 
    285 ! 
    286     if ( Agrif_Curgrid%level <= 0 ) return 
    287 ! 
    288     indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0 
    289 ! 
    290     if ( present(calledweight) ) then 
    291         weight  = calledweight 
    292         pweight = .true. 
    293     else 
    294         weight  = 0. 
    295         pweight = .false. 
    296     endif 
    297 ! 
    298     if (indic <= 0) then 
    299         child_var  => Agrif_Search_Variable(Agrif_Curgrid,-indic) 
    300         parent_var => child_var % parent_var 
    301         root_var   => child_var % root_var 
    302     else 
    303         print*,"Agrif_Bc_variable : warning indic >= 0 !!!" 
    304         child_var  => Agrif_Curgrid % tabvars(indic) 
    305         parent_var => Agrif_Curgrid % parent % tabvars(indic) 
    306         root_var   => Agrif_Mygrid % tabvars(indic) 
    307     endif 
    308 ! 
    309     nbdim = root_var % nbdim 
    310 ! 
    311     select case( nbdim ) 
    312     case(1) 
    313         allocate(parray1(child_var%lb(1):child_var%ub(1))) 
    314     case(2) 
    315         allocate(parray2(child_var%lb(1):child_var%ub(1), & 
    316                          child_var%lb(2):child_var%ub(2) )) 
    317     case(3) 
    318         allocate(parray3(child_var%lb(1):child_var%ub(1), & 
    319                          child_var%lb(2):child_var%ub(2), & 
    320                          child_var%lb(3):child_var%ub(3) )) 
    321     case(4) 
    322         allocate(parray4(child_var%lb(1):child_var%ub(1), & 
    323                          child_var%lb(2):child_var%ub(2), & 
    324                          child_var%lb(3):child_var%ub(3), & 
    325                          child_var%lb(4):child_var%ub(4) )) 
    326     case(5) 
    327         allocate(parray5(child_var%lb(1):child_var%ub(1), & 
    328                          child_var%lb(2):child_var%ub(2), & 
    329                          child_var%lb(3):child_var%ub(3), & 
    330                          child_var%lb(4):child_var%ub(4), & 
    331                          child_var%lb(5):child_var%ub(5) )) 
    332     case(6) 
    333         allocate(parray6(child_var%lb(1):child_var%ub(1), & 
    334                          child_var%lb(2):child_var%ub(2), & 
    335                          child_var%lb(3):child_var%ub(3), & 
    336                          child_var%lb(4):child_var%ub(4), & 
    337                          child_var%lb(5):child_var%ub(5), & 
    338                          child_var%lb(6):child_var%ub(6) )) 
    339     end select 
    340 ! 
    341 !   Create temporary child variable 
    342     allocate(child_tmp) 
    343 ! 
    344     child_tmp % root_var => root_var 
    345     child_tmp % oldvalues2D => child_var % oldvalues2D 
    346 ! 
    347 !   Index indicating if a space interpolation is necessary 
    348     child_tmp % interpIndex =  child_var % interpIndex 
    349     child_tmp % list_interp => child_var % list_interp 
    350     child_tmp % Interpolationshouldbemade = child_var % Interpolationshouldbemade 
    351 ! 
    352     child_tmp % point = child_var % point 
    353     child_tmp % lb = child_var % lb 
    354     child_tmp % ub = child_var % ub 
    355 ! 
    356     child_tmp % bcinf = child_var % bcinf 
    357     child_tmp % bcsup = child_var % bcsup 
    358 ! 
    359     child_tmp % childarray = child_var % childarray 
    360     child_tmp % memberin   = child_var % memberin 
    361 ! 
    362     call Agrif_CorrectVariable(parent_var, child_tmp, pweight, weight, procname) 
    363 ! 
    364     child_var % childarray = child_tmp % childarray 
    365     child_var % memberin   = child_tmp % memberin 
    366 ! 
    367     child_var % oldvalues2D => child_tmp % oldvalues2D 
    368     child_var % list_interp => child_tmp % list_interp 
    369 ! 
    370     child_var % interpIndex = child_tmp % interpIndex 
    371 ! 
    372     deallocate(child_tmp) 
    373 ! 
    374     select case( nbdim ) 
    375         case(1); deallocate(parray1) 
    376         case(2); deallocate(parray2) 
    377         case(3); deallocate(parray3) 
    378         case(4); deallocate(parray4) 
    379         case(5); deallocate(parray5) 
    380         case(6); deallocate(parray6) 
    381     end select 
    382 !--------------------------------------------------------------------------------------------------- 
    383 end subroutine Agrif_Bc_variable 
    384 !=================================================================================================== 
    385 ! 
    386 !=================================================================================================== 
    387 !  subroutine Agrif_Interp_variable 
    388 !--------------------------------------------------------------------------------------------------- 
    389 subroutine Agrif_Interp_variable ( tabvarsindic, procname ) 
    390 !--------------------------------------------------------------------------------------------------- 
    391     integer,     intent(in)     :: tabvarsindic     !< indice of the variable in tabvars 
    392     procedure()                 :: procname         !< Data recovery procedure 
    393 ! 
    394     integer :: nbdim 
    395     integer :: indic  ! indice of the variable in tabvars 
    396     logical :: torestore 
    397     type(Agrif_Variable), pointer   :: root_var 
    398     type(Agrif_Variable), pointer   :: parent_var       ! Variable on the parent grid 
    399     type(Agrif_Variable), pointer   :: child_var        ! Variable on the parent grid 
    400     type(Agrif_Variable), pointer   :: child_tmp        ! Temporary variable on the child grid 
    401 ! 
    402     if ( Agrif_Curgrid%level <= 0 ) return 
    403 ! 
    404     indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0 
    405 ! 
    406     if (indic <= 0) then 
    407         child_var  => Agrif_Search_Variable(Agrif_Curgrid,-indic) 
    408         parent_var => child_var % parent_var 
    409         root_var   => child_var % root_var 
    410     else 
    411         print*,"Agrif_Interp_variable : warning indic >= 0 !!!" 
    412         child_var  => Agrif_Curgrid % tabvars(indic) 
    413         parent_var => Agrif_Curgrid % parent % tabvars(indic) 
    414         root_var   => Agrif_Mygrid % tabvars(indic) 
    415     endif 
    416 ! 
    417     nbdim     = root_var % nbdim 
    418     torestore = root_var % restore 
    419 ! 
    420     allocate(child_tmp) 
    421 ! 
    422     child_tmp % root_var => root_var 
    423     child_tmp % nbdim = root_var % nbdim 
    424     child_tmp % point = child_var % point 
    425     child_tmp % lb = child_var % lb 
    426     child_tmp % ub = child_var % ub 
    427     child_tmp % interpIndex =  child_var % interpIndex 
    428     child_tmp % list_interp => child_var % list_interp 
    429     child_tmp % Interpolationshouldbemade = child_var % Interpolationshouldbemade 
    430 ! 
    431     if ( torestore ) then 
    432         select case( nbdim ) 
    433         case(1) 
    434             parray1 = child_var % array1 
    435             child_tmp % restore1D => child_var % restore1D 
    436         case(2) 
    437             parray2 = child_var % array2 
    438             child_tmp % restore2D => child_var % restore2D 
    439         case(3) 
    440             parray3 = child_var % array3 
    441             child_tmp % restore3D => child_var % restore3D 
    442         case(4) 
    443             parray4 = child_var % array4 
    444             child_tmp % restore4D => child_var % restore4D 
    445         case(5) 
    446             parray5 = child_var % array5 
    447             child_tmp % restore5D => child_var % restore5D 
    448         case(6) 
    449             parray6 = child_var % array6 
    450             child_tmp % restore6D => child_var % restore6D 
    451         end select 
    452     endif 
    453 ! 
    454     call Agrif_InterpVariable(parent_var, child_tmp, torestore, procname) 
    455 ! 
    456     child_var % list_interp => child_tmp % list_interp 
    457 ! 
    458     deallocate(child_tmp) 
    459 !--------------------------------------------------------------------------------------------------- 
    460 end subroutine Agrif_Interp_variable 
    461 !=================================================================================================== 
    462 ! 
    463 !=================================================================================================== 
    464 !  subroutine Agrif_Update_Variable 
    465 !--------------------------------------------------------------------------------------------------- 
    466 subroutine Agrif_Update_Variable ( tabvarsindic, procname, & 
    467                                    locupdate, locupdate1, locupdate2, locupdate3, locupdate4 ) 
    468 !--------------------------------------------------------------------------------------------------- 
    469     integer,               intent(in)           :: tabvarsindic     !< Indice of the variable in tabvars 
    470     procedure()                                 :: procname         !< Data recovery procedure 
    471     integer, dimension(2), intent(in), optional :: locupdate 
    472     integer, dimension(2), intent(in), optional :: locupdate1 
    473     integer, dimension(2), intent(in), optional :: locupdate2 
    474     integer, dimension(2), intent(in), optional :: locupdate3 
    475     integer, dimension(2), intent(in), optional :: locupdate4 
    476 !--------------------------------------------------------------------------------------------------- 
    477     integer :: indic 
    478     integer :: nbdim 
    479     integer, dimension(6)           :: updateinf    ! First positions where interpolations are calculated 
    480     integer, dimension(6)           :: updatesup    ! Last  positions where interpolations are calculated 
    481     type(Agrif_Variable), pointer   :: root_var 
    482     type(Agrif_Variable), pointer   :: parent_var 
    483     type(Agrif_Variable), pointer   :: child_var 
    484 ! 
    485     if ( Agrif_Root() .AND. (.not.agrif_coarse) ) return 
    486     if (agrif_curgrid%grand_mother_grid) return 
    487 ! 
    488     indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0 
    489 ! 
    490     if (indic <= 0) then 
    491         child_var  => Agrif_Search_Variable(Agrif_Curgrid, -indic) 
    492         parent_var => child_var % parent_var 
    493  
    494         if (.not.associated(parent_var)) then 
    495           ! can occur during the first update of Agrif_Coarsegrid (if any) 
    496           parent_var => Agrif_Search_Variable(Agrif_Curgrid % parent, -indic) 
    497           child_var % parent_var => parent_var 
    498         endif 
    499  
    500         root_var   => child_var % root_var 
    501     else 
    502         print*,"Agrif_Update_Variable : warning indic >= 0 !!!" 
    503         root_var   => Agrif_Mygrid  % tabvars(indic) 
    504         child_var  => Agrif_Curgrid % tabvars(indic) 
    505         parent_var => Agrif_Curgrid % parent % tabvars(indic) 
    506     endif 
    507 ! 
    508     nbdim = root_var % nbdim 
    509 ! 
    510     updateinf = -99 
    511     updatesup = -99 
    512 ! 
    513     if ( present(locupdate) ) then 
    514         updateinf(1:nbdim) = locupdate(1) 
    515         updatesup(1:nbdim) = locupdate(2) 
    516     endif 
    517 ! 
    518     if ( present(locupdate1) ) then 
    519         updateinf(1) = locupdate1(1) 
    520         updatesup(1) = locupdate1(2) 
    521     endif 
    522 ! 
    523     if ( present(locupdate2) ) then 
    524         updateinf(2) = locupdate2(1) 
    525         updatesup(2) = locupdate2(2) 
    526     endif 
    527  
    528     if ( present(locupdate3) ) then 
    529         updateinf(3) = locupdate3(1) 
    530         updatesup(3) = locupdate3(2) 
    531     endif 
    532  
    533     if ( present(locupdate4) ) then 
    534         updateinf(4) = locupdate4(1) 
    535         updatesup(4) = locupdate4(2) 
    536     endif 
    537 ! 
    538     call Agrif_UpdateVariable( parent_var, child_var, updateinf, updatesup, procname ) 
    539 !--------------------------------------------------------------------------------------------------- 
    540 end subroutine Agrif_Update_Variable 
    541 !=================================================================================================== 
    542 ! 
    543 !=================================================================================================== 
    54466!  subroutine Agrif_Save_ForRestore0D 
    54567!--------------------------------------------------------------------------------------------------- 
    54668subroutine Agrif_Save_ForRestore0D ( tabvarsindic0, tabvarsindic ) 
    54769!--------------------------------------------------------------------------------------------------- 
    548     integer, intent(in) :: tabvarsindic0, tabvarsindic 
     70    integer, intent(in) :: tabvarsindic0 !< index of the current grid variable  
     71    integer, intent(in) :: tabvarsindic  !< index of the varible which should be restored 
     72     
    54973! 
    55074    type(Agrif_Variable), pointer   :: root_var, save_var 
    55175    integer :: nbdim 
    55276! 
     77print *,'CURRENTLY BROKEN' 
     78STOP 
    55379    root_var => Agrif_Mygrid % tabvars(tabvarsindic0) 
    55480    save_var => Agrif_Curgrid % tabvars(tabvarsindic0) 
     
    56692!=================================================================================================== 
    56793!  subroutine Agrif_Save_ForRestore2D 
     94!> This function is used to restore a current grid variable (with the index tabvarsindic) to the input 2D-variable. 
    56895!--------------------------------------------------------------------------------------------------- 
    56996subroutine Agrif_Save_ForRestore2D ( q, tabvarsindic ) 
    57097!--------------------------------------------------------------------------------------------------- 
    571     real, dimension(:,:), intent(in)        :: q 
    572     integer,              intent(in)        :: tabvarsindic 
     98! 
     99real, dimension(:,:), intent(in) :: q            !< input 2D-variable which should be saved 
     100integer,            intent(in) :: tabvarsindic !< index of the current grid variable we want to restore 
    573101! 
    574102    type(Agrif_Variable),  pointer  :: root_var, save_var 
    575103    integer                         :: indic 
    576104! 
     105print *,'CURRENTLY BROKEN' 
     106STOP 
    577107    indic = tabvarsindic 
    578108    if (tabvarsindic >= 0) then 
     
    603133!=================================================================================================== 
    604134!  subroutine Agrif_Save_ForRestore3D 
     135!> This function is used to restore a current grid variable (with the index tabvarsindic) to the input 3D-variable. 
    605136!--------------------------------------------------------------------------------------------------- 
    606137subroutine Agrif_Save_ForRestore3D ( q, tabvarsindic ) 
    607138!--------------------------------------------------------------------------------------------------- 
    608     real, dimension(:,:,:), intent(in)      :: q 
    609     integer,                intent(in)      :: tabvarsindic 
     139! 
     140real, dimension(:,:,:), intent(in) :: q !< input 3D-variable which should be saved 
     141integer, intent(in) :: tabvarsindic    !< index of the current grid variable we want to restore 
    610142! 
    611143    type(Agrif_Variable),  pointer  :: root_var, save_var 
    612144    integer                         :: indic 
    613145! 
     146print *,'CURRENTLY BROKEN' 
     147STOP 
     148 
    614149    indic = tabvarsindic 
    615150    if (tabvarsindic >= 0) then 
     
    641176!=================================================================================================== 
    642177!  subroutine Agrif_Save_ForRestore4D 
     178!> This function is used to restore a current grid variable (with the index tabvarsindic) to the input 4D-variable. 
    643179!--------------------------------------------------------------------------------------------------- 
    644180subroutine Agrif_Save_ForRestore4D ( q, tabvarsindic ) 
    645181!--------------------------------------------------------------------------------------------------- 
    646     real, dimension(:,:,:,:), intent(in)    :: q 
    647     integer,                  intent(in)    :: tabvarsindic 
     182! 
     183real, dimension(:,:,:,:), intent(in) :: q !< input 4D-variable which should be saved 
     184integer, intent(in) :: tabvarsindic      !< index of the current grid variable we want to restore 
     185! 
    648186! 
    649187    type(Agrif_Variable),  pointer  :: root_var, save_var 
    650188    integer                         :: indic 
    651189! 
     190print *,'CURRENTLY BROKEN' 
     191STOP 
    652192    indic = tabvarsindic 
    653193    if (tabvarsindic >= 0) then 
  • vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modcluster.F90

    r5656 r10087  
    2929module Agrif_Clustering 
    3030! 
    31     use Agrif_CurgridFunctions 
     31    !use Agrif_CurgridFunctions 
     32    !use Agrif_Init_Vars 
     33    !use Agrif_Save 
    3234    use Agrif_Init_Vars 
    3335    use Agrif_Save 
     36    use Agrif_Init 
    3437! 
    3538    implicit none 
     
    5457    TYPE(Agrif_LRectangle), pointer  :: parcours 
    5558    TYPE(Agrif_Grid)      , pointer  :: newgrid 
    56     REAL                             :: g_eps 
     59    REAL(kind=8)                     :: g_eps 
    5760    INTEGER                          :: i 
    5861! 
     
    131134    TYPE(Agrif_PGrid), pointer  :: parcours 
    132135! 
    133     REAL                  :: g_eps, newgrid_eps, eps 
    134     REAL   , DIMENSION(3) :: newmin, newmax 
    135     REAL   , DIMENSION(3) :: gmin, gmax 
    136     REAL   , DIMENSION(3) :: xmin 
     136    REAL(kind=8)                  :: g_eps, newgrid_eps, eps 
     137    REAL(kind=8)   , DIMENSION(3) :: newmin, newmax 
     138    REAL(kind=8)   , DIMENSION(3) :: gmin, gmax 
     139    REAL(kind=8)   , DIMENSION(3) :: xmin 
    137140    INTEGER, DIMENSION(3) :: igmin, inewmin 
    138141    INTEGER, DIMENSION(3) :: inewmax 
  • vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modcurgridfunctions.F90

    r5656 r10087  
    9292! 
    9393    rhot = float(Agrif_IRhot()) 
     94     
    9495!--------------------------------------------------------------------------------------------------- 
    9596end function Agrif_Rhot 
  • vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modgrids.F90

    r5656 r10087  
    4444    type(Agrif_Variable_i), dimension(:), allocatable :: tabvars_i  !< List of integer   grid variables 
    4545! 
    46     real   , dimension(3)              :: Agrif_x   !< global x, y and z position 
    47     real   , dimension(3)              :: Agrif_dx  !< global space step in the x, y and z direction 
    48     real   , dimension(3)              :: Agrif_dt  !< global time  step in the x, y and z direction 
     46    real(kind=8), dimension(3)         :: Agrif_x   !< global x, y and z position 
     47    real(kind=8)   , dimension(3)      :: Agrif_dx  !< global space step in the x, y and z direction 
     48    real, dimension(3)                 :: Agrif_dt  !< global time  step in the x, y and z direction 
    4949    integer, dimension(3)              :: nb        !< number of cells in the x, y and z direction 
    5050    integer, dimension(3)              :: ix        !< minimal position in the x, y and z direction 
  • vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modinit.F90

    r5656 r10087  
    3131! 
    3232    implicit none 
     33 
     34    abstract interface 
     35        subroutine step_proc() 
     36        end subroutine step_proc 
     37    end interface 
     38     
    3339! 
    3440contains 
    3541! 
     42 
     43 
     44subroutine Agrif_call_procname ( procname ) 
     45    procedure(step_proc)  :: procname 
     46    call procname() 
     47end subroutine  Agrif_call_procname 
     48!=================================================================================================== 
     49 
     50subroutine Agrif_call_procname1 ( procname1 ) 
     51    procedure(typedef_proc) :: procname1  
     52    call procname1() 
     53end subroutine  Agrif_call_procname1 
     54 
    3655!=================================================================================================== 
    3756!  subroutine Agrif_Allocation 
  • vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modinterp.F90

    r7752 r10087  
    2626module Agrif_Interpolation 
    2727! 
    28     use Agrif_InterpBasic 
    29     use Agrif_Arrays 
    30     use Agrif_Mask 
    31     use Agrif_CurgridFunctions 
     28  use Agrif_Init 
     29  use Agrif_Arrays 
     30  use Agrif_InterpBasic 
     31  use Agrif_User_Functions 
     32 
    3233#if defined AGRIF_MPI 
    3334    use Agrif_Mpp 
    3435#endif 
     36   
     37    use Agrif_Mask 
    3538! 
    3639    implicit none 
     
    6669    integer, dimension(6) :: ub_child 
    6770    integer, dimension(6) :: lb_parent 
    68     real   , dimension(6) :: s_child,   s_parent 
    69     real   , dimension(6) :: ds_child, ds_parent 
     71    real(kind=8)   , dimension(6) :: s_child,   s_parent 
     72    real(kind=8)   , dimension(6) :: ds_child, ds_parent 
    7073    integer, dimension(child % root_var % nbdim,2,2) :: childarray 
    7174! 
     
    115118    INTEGER, DIMENSION(nbdim), INTENT(in)   :: pttab_Parent !< Index of the first point inside the domain 
    116119                                                            !<    for the parent grid variable 
    117     REAL,    DIMENSION(nbdim), INTENT(in)   :: s_Child,s_Parent   !< Positions of the parent and child grids 
    118     REAL,    DIMENSION(nbdim), INTENT(in)   :: ds_Child,ds_Parent !< Space steps of the parent and child grids 
     120    REAL(kind=8),    DIMENSION(nbdim), INTENT(in)   :: s_Child,s_Parent   !< Positions of the parent and child grids 
     121    REAL(kind=8),    DIMENSION(nbdim), INTENT(in)   :: ds_Child,ds_Parent !< Space steps of the parent and child grids 
    119122    TYPE(Agrif_Variable),      pointer      :: restore            !< Indicates points where interpolation 
    120123    LOGICAL,                   INTENT(in)   :: torestore          !< Indicates if the array restore is used 
     
    128131    INTEGER                       :: i,j,k,l,m,n 
    129132    INTEGER, DIMENSION(nbdim)     :: pttruetab,cetruetab 
    130     INTEGER, DIMENSION(nbdim)     :: indmin,     indmax 
     133    INTEGER, DIMENSION(nbdim)     :: indmin,     indmax, indmin_required_p, indmax_required_p 
    131134    INTEGER, DIMENSION(nbdim)     :: indminglob, indmaxglob 
    132135#if defined AGRIF_MPI 
    133136    INTEGER, DIMENSION(nbdim)     :: indminglob2,indmaxglob2 
     137    INTEGER, DIMENSION(nbdim)     :: indminglob3,indmaxglob3 
    134138#endif 
    135139    LOGICAL, DIMENSION(nbdim)     :: noraftab 
    136     REAL   , DIMENSION(nbdim)     :: s_Child_temp,s_Parent_temp 
     140    REAL(kind=8)   , DIMENSION(nbdim)     :: s_Child_temp,s_Parent_temp,s_Parent_temp_p 
    137141    INTEGER, DIMENSION(nbdim)     :: lowerbound, upperbound, coords 
    138142    INTEGER, DIMENSION(nbdim,2,2), INTENT(OUT) :: childarray 
     
    148152    INTEGER, DIMENSION(nbdim,4,0:Agrif_Nbprocs-1)   :: tab4 
    149153    INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1,8)   :: tab4t 
     154    INTEGER,DIMENSION(nbdim,2) :: tab5 
     155    INTEGER,DIMENSION(nbdim,2,0:Agrif_Nbprocs-1) :: tab6 
     156    INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,2) :: tab5t 
    150157    LOGICAL, DIMENSION(0:Agrif_Nbprocs-1)           :: memberinall 
    151158    LOGICAL, DIMENSION(0:Agrif_Nbprocs-1)           :: sendtoproc1, recvfromproc1 
     
    167174            child % list_interp,                                    & 
    168175            pttab, petab, pttab_Child, pttab_Parent, nbdim,         & 
    169             indmin, indmax, indminglob, indmaxglob,                 & 
     176            indmin, indmax, indmin_required_p, indmax_required_p,   & 
     177            indminglob, indmaxglob,                                 & 
    170178            pttruetab, cetruetab, memberin                          & 
    171179#if defined AGRIF_MPI 
     
    174182#endif 
    175183        ) 
     184 
    176185! 
    177186    if (.not.find_list_interp) then 
    178187! 
     188! output : lowerbound and upperbound are the (local) lower and upper bounds of the child arrays 
     189 
    179190        call Agrif_get_var_bounds_array(child, lowerbound, upperbound, nbdim) 
     191 
     192! input : pttab, petab : global indexes where the interpolation is required 
     193! output : pttruetab, cetruetab : global indexes restricted to the bounds of the current processor  
     194! output : memberin is false if the current processor is not involved in the interpolation 
     195 
    180196        call Agrif_Childbounds(nbdim, lowerbound, upperbound,               & 
    181197                               pttab, petab, Agrif_Procrank, coords,        & 
    182198                               pttruetab, cetruetab, memberin) 
     199          
     200 
     201 
     202! output : indminglob, indmaxglob : global indexes required on the parent grid for the interpolation 
     203! output : s_Parent_temp, s_Child_temp : local s_Parent, s_Child relatively to indmin ou pttab 
    183204        call Agrif_Parentbounds(type_interp,nbdim,indminglob,indmaxglob,    & 
     205                                indmin_required_p, indmax_required_p,           & 
    184206                                s_Parent_temp,s_Child_temp,                 & 
    185207                                s_Child,ds_Child,                           & 
     
    190212#if defined AGRIF_MPI 
    191213        if (memberin) then 
     214 
     215! output : indmin, indmax : global indexes required on the parent grid for the interpolation on the current processor (i.e. on pttruetab, cetruetab) 
     216! output : s_Parent_temp, s_Child_temp : local s_Parent, s_Child relatively to indmin ou pttruetab 
    192217            call Agrif_Parentbounds(type_interp,nbdim,indmin,indmax,        & 
     218                                    indmin_required_p, indmax_required_p,       & 
    193219                                    s_Parent_temp,s_Child_temp,             & 
    194220                                    s_Child,ds_Child,                       & 
     
    200226 
    201227        local_proc = Agrif_Procrank 
     228 
     229! output : lowerbound and upperbound are the (local) lower and upper bounds of the parent arrays 
    202230        call Agrif_get_var_bounds_array(parent,lowerbound,upperbound,nbdim) 
    203231        call Agrif_ChildGrid_to_ParentGrid() 
    204 ! 
     232 
     233! input : indminglob,indmaxglob : global indexes where data are required for the interpolation 
     234! output : indminglob2,indmaxglob2 : global indexes restricted to the bounds of the current processor  
     235! output : member is false if the current processor does not need to send data 
     236! output : indminglob3,indmaxglob3 : global bounds on the current processor for the parent array 
     237 
    205238        call Agrif_Childbounds(nbdim,lowerbound,upperbound,                 & 
    206239                               indminglob,indmaxglob, local_proc, coords,   & 
    207                                indminglob2,indmaxglob2,member) 
     240                               indminglob2,indmaxglob2,member,              & 
     241                               indminglob3,indmaxglob3) 
    208242! 
    209243        if (member) then 
     244 
     245! output : parentarray 
     246! output : parentarray (:,:,2) : indminglob2, indmaxglob2 in term of local indexes on current processor 
     247! output : parentarray (:,:,1) : indminglob2, indmaxglob2 restricted to the current processor (different from indminglob2 ???) 
     248! output : member is .false. is the current processor has not data to send 
     249 
    210250            call Agrif_GlobalToLocalBounds(parentarray,                     & 
    211251                                           lowerbound,  upperbound,         & 
     
    216256        call Agrif_ParentGrid_to_ChildGrid() 
    217257#else 
     258 
     259! In the sequentiel case, the following lines ensure that the bounds needed on the parent grid in the interpolation  
     260! do not exceed lower and upper bounds of the parent array 
     261 
     262! output : lowerbound and upperbound are the (local) lower and upper bounds of the parent arrays 
     263        call Agrif_get_var_bounds_array(parent,lowerbound,upperbound,nbdim) 
     264        call Agrif_ChildGrid_to_ParentGrid() 
     265 
     266! input : indminglob,indmaxglob : global indexes where data are required for the interpolation 
     267! output : indminglob2,indmaxglob2 : global indexes restricted to the bounds of the current processor  
     268! output : member is false if the current processor does not need to send data 
     269 
     270        call Agrif_Childbounds(nbdim,lowerbound,upperbound,                 & 
     271                               indminglob,indmaxglob, Agrif_Procrank, coords,   & 
     272                               indmin,indmax,member) 
     273 
     274        call Agrif_ParentGrid_to_ChildGrid() 
     275 
     276        indminglob = indmin 
     277        indmaxglob = indmax 
     278 
    218279        parentarray(:,1,1) = indminglob 
    219280        parentarray(:,2,1) = indmaxglob 
    220281        parentarray(:,1,2) = indminglob 
    221282        parentarray(:,2,2) = indmaxglob 
    222         indmin = indminglob 
    223         indmax = indmaxglob 
     283  
     284!       indmin = indminglob 
     285!        indmax = indmaxglob 
     286 
    224287        member = .TRUE. 
     288        s_Parent_temp = s_Parent + (indminglob - pttab_Parent) * ds_Parent 
     289 
    225290#endif 
     291!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
     292! Correct for non refined directions 
     293!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
     294        do i=1,nbdim 
     295          if (coords(i) == 0) then 
     296             indmin(i) = indminglob(i) 
     297             indmax(i) = indmaxglob(i) 
     298             pttruetab(i) = indminglob(i) 
     299             cetruetab(i) = indmaxglob(i) 
     300          endif 
     301        enddo 
    226302 
    227303    else 
     
    231307        s_Child_temp  = s_Child + (pttruetab - pttab_Child) * ds_Child 
    232308#else 
     309 
     310! In the sequentiel case, the following lines ensure that the bounds needed on the parent grid in the interpolation  
     311! do not exceed lower and upper bounds of the parent array 
     312 
     313! output : lowerbound and upperbound are the (local) lower and upper bounds of the parent arrays 
     314        call Agrif_get_var_bounds_array(parent,lowerbound,upperbound,nbdim) 
     315        call Agrif_ChildGrid_to_ParentGrid() 
     316 
     317! input : indminglob,indmaxglob : global indexes where data are required for the interpolation 
     318! output : indminglob2,indmaxglob2 : global indexes restricted to the bounds of the current processor  
     319! output : member is false if the current processor does not need to send data 
     320 
     321        call Agrif_Childbounds(nbdim,lowerbound,upperbound,                 & 
     322                               indminglob,indmaxglob, Agrif_Procrank, coords,   & 
     323                               indmin,indmax,member) 
     324 
     325        call Agrif_ParentGrid_to_ChildGrid() 
     326 
     327        indminglob = indmin 
     328        indmaxglob = indmax 
     329 
    233330        parentarray(:,1,1) = indminglob 
    234331        parentarray(:,2,1) = indmaxglob 
    235332        parentarray(:,1,2) = indminglob 
    236333        parentarray(:,2,2) = indmaxglob 
    237         indmin = indminglob 
    238         indmax = indmaxglob 
     334 !       indmin = indminglob 
     335 !       indmax = indmaxglob 
    239336        member = .TRUE. 
    240337        s_Parent_temp = s_Parent + (indminglob - pttab_Parent) * ds_Parent 
     
    246343        if (.not.associated(tempP)) allocate(tempP) 
    247344! 
     345 
    248346        call Agrif_array_allocate(tempP,parentarray(:,1,1),parentarray(:,2,1),nbdim) 
    249347        call Agrif_var_set_array_tozero(tempP,nbdim) 
     
    286384                      parentarray(6,1,2),parentarray(6,2,2),.TRUE.,nb,ndir) 
    287385        end select 
     386 
    288387! 
    289388        call Agrif_ParentGrid_to_ChildGrid() 
     
    298397        tab3(:,3) = indmin(:) 
    299398        tab3(:,4) = indmax(:) 
     399        tab5(:,1) = indminglob3(:) 
     400        tab5(:,2) = indmaxglob3(:) 
    300401! 
    301402        call MPI_ALLGATHER(tab3,4*nbdim,MPI_INTEGER,tab4,4*nbdim,MPI_INTEGER,Agrif_mpi_comm,code) 
    302  
     403        call MPI_ALLGATHER(tab5,2*nbdim,MPI_INTEGER,tab6,2*nbdim,MPI_INTEGER,Agrif_mpi_comm,code) 
    303404        if (.not.associated(tempPextend))   allocate(tempPextend) 
    304405 
     
    311412        enddo 
    312413 
     414        do k=0,Agrif_Nbprocs-1 
     415          do j=1,2 
     416            do i=1,nbdim 
     417               tab5t(i,k,j) = tab6(i,j,k) 
     418            enddo 
     419          enddo 
     420        enddo 
     421       
    313422        memberin1(1) = memberin 
    314423        call MPI_ALLGATHER(memberin1,1,MPI_LOGICAL,memberinall,1,MPI_LOGICAL,Agrif_mpi_comm,code) 
     
    319428                                     sendtoproc1,recvfromproc1,         & 
    320429                                     tab4t(:,:,5),tab4t(:,:,6),         & 
    321                                      tab4t(:,:,7),tab4t(:,:,8) ) 
     430                                     tab4t(:,:,7),tab4t(:,:,8),         & 
     431                                     tab5t(:,:,1),tab5t(:,:,2)) 
    322432    endif 
    323433 
     
    333443                child%list_interp,pttab,petab,                  & 
    334444                pttab_Child,pttab_Parent,indmin,indmax,         & 
     445                indmin_required_p, indmax_required_p,           & 
    335446                indminglob,indmaxglob,                          & 
    336447                pttruetab,cetruetab,                            & 
     
    345456    endif 
    346457! 
     458 
    347459    if (memberin) then 
    348460! 
    349461        if (.not.associated(tempC)) allocate(tempC) 
    350462! 
     463 
    351464        call Agrif_array_allocate(tempC,pttruetab,cetruetab,nbdim) 
     465 
    352466! 
    353467!       Special values on the parent grid 
     
    357471! 
    358472            if (.not.associated(parentvalues))  allocate(parentvalues) 
    359 ! 
     473!t 
     474 
    360475            call Agrif_array_allocate(parentvalues,indmin,indmax,nbdim) 
    361476            call Agrif_var_full_copy_array(parentvalues,tempPextend,nbdim) 
    362477! 
    363             call Agrif_CheckMasknD(tempPextend,parentvalues,    & 
    364                     indmin(1:nbdim),indmax(1:nbdim),            & 
    365                     indmin(1:nbdim),indmax(1:nbdim),            & 
     478            call Agrif_CheckMasknD(tempPextend,parentvalues,                & 
     479                    indmin(1:nbdim),indmax(1:nbdim),                        & 
     480                    indmin(1:nbdim),indmax(1:nbdim),                        & 
     481                    indmin_required_p(1:nbdim),indmax_required_p(1:nbdim),  & 
    366482                    noraftab(1:nbdim),nbdim) 
    367483! 
     
    391507                                                ds_Child(1:2),    ds_Parent(1:2) ) 
    392508            case(3) 
    393                 call Agrif_Interp_3D_recursive( type_interp(1:3),                       & 
    394                                                 tempPextend % array3,                   & 
    395                                                 tempC       % array3,                   & 
    396                                                 indmin(1:3), indmax(1:3),               & 
    397                                                 pttruetab(1:3),    cetruetab(1:3),      & 
    398                                                 s_Child_temp(1:3), s_Parent_temp(1:3),  & 
     509                s_Parent_temp_p = s_Parent + (indmin_required_p - pttab_Parent) * ds_Parent 
     510                call Agrif_Interp_3D_recursive( type_interp(1:3),                                 & 
     511                                                tempPextend % array3(                             & 
     512                                                indmin_required_p(1):indmax_required_p(1),        & 
     513                                                indmin_required_p(2):indmax_required_p(2),        & 
     514                                                indmin_required_p(3):indmax_required_p(3)),       & 
     515                                                tempC       % array3,                             & 
     516                                                indmin_required_p(1:3), indmax_required_p(1:3),   & 
     517                                                pttruetab(1:3),    cetruetab(1:3),                & 
     518                                                s_Child_temp(1:3), s_Parent_temp_p(1:3),          & 
    399519                                                ds_Child(1:3),    ds_Parent(1:3) ) 
     520 
    400521            case(4) 
    401                 call Agrif_Interp_4D_recursive( type_interp(1:4),                       & 
    402                                                 tempPextend % array4,                   & 
    403                                                 tempC       % array4,                   & 
    404                                                 indmin(1:4), indmax(1:4),               & 
    405                                                 pttruetab(1:4),    cetruetab(1:4),      & 
    406                                                 s_Child_temp(1:4), s_Parent_temp(1:4),  & 
     522                s_Parent_temp_p = s_Parent + (indmin_required_p - pttab_Parent) * ds_Parent 
     523                call Agrif_Interp_4D_recursive( type_interp(1:4),                                 & 
     524                                                tempPextend % array4(                             & 
     525                                                indmin_required_p(1):indmax_required_p(1),        & 
     526                                                indmin_required_p(2):indmax_required_p(2),        & 
     527                                                indmin_required_p(3):indmax_required_p(3),        & 
     528                                                indmin_required_p(4):indmax_required_p(4)),       & 
     529                                                tempC       % array4,                             & 
     530                                                indmin_required_p(1:4), indmax_required_p(1:4),   & 
     531                                                pttruetab(1:4),    cetruetab(1:4),                & 
     532                                                s_Child_temp(1:4), s_Parent_temp_p(1:4),          & 
    407533                                                ds_Child(1:4),    ds_Parent(1:4) ) 
    408534            case(5) 
     
    595721        else    ! .not.to_restore 
    596722! 
     723 
    597724            if (memberin) then 
    598725    ! 
     
    715842        endif 
    716843 
     844 
    717845        call Agrif_array_deallocate(tempPextend,nbdim) 
    718846        call Agrif_array_deallocate(tempC,nbdim) 
     
    736864!--------------------------------------------------------------------------------------------------- 
    737865subroutine Agrif_Parentbounds ( type_interp, nbdim, indmin, indmax, & 
     866                                indmin_required,indmax_required,    & 
    738867                                s_Parent_temp, s_Child_temp,        & 
    739868                                s_Child, ds_Child,                  & 
     
    745874    INTEGER,                   intent(in)  :: nbdim 
    746875    INTEGER, DIMENSION(nbdim), intent(out) :: indmin, indmax 
    747     REAL,    DIMENSION(nbdim), intent(out) :: s_Parent_temp, s_child_temp 
    748     REAL,    DIMENSION(nbdim), intent(in)  :: s_Child, ds_child 
    749     REAL,    DIMENSION(nbdim), intent(in)  :: s_Parent,ds_Parent 
     876    INTEGER, DIMENSION(nbdim), intent(out) :: indmin_required, indmax_required 
     877    REAL(kind=8),    DIMENSION(nbdim), intent(out) :: s_Parent_temp, s_child_temp 
     878    REAL(kind=8),    DIMENSION(nbdim), intent(in)  :: s_Child, ds_child 
     879    REAL(kind=8),    DIMENSION(nbdim), intent(in)  :: s_Parent,ds_Parent 
    750880    INTEGER, DIMENSION(nbdim), intent(in)  :: pttruetab, cetruetab 
    751881    INTEGER, DIMENSION(nbdim), intent(in)  :: pttab_Child, pttab_Parent 
     
    753883    INTEGER, DIMENSION(nbdim), intent(in)  :: coords 
    754884! 
     885    REAL(kind=8) :: xpmin, xpmax 
     886    INTEGER :: coeffraf 
    755887    INTEGER :: i 
    756     REAL,DIMENSION(nbdim) :: dim_newmin, dim_newmax 
     888    REAL(kind=8),DIMENSION(nbdim) :: dim_newmin, dim_newmax 
    757889! 
    758890    dim_newmin = s_Child + (pttruetab - pttab_Child) * ds_Child 
     
    763895        indmin(i) = pttab_Parent(i) + agrif_int((dim_newmin(i)-s_Parent(i))/ds_Parent(i)) 
    764896        indmax(i) = pttab_Parent(i) + agrif_ceiling((dim_newmax(i)-s_Parent(i))/ds_Parent(i)) 
     897 
     898        coeffraf = nint(ds_Parent(i)/ds_Child(i)) 
     899         
     900        indmin_required(i) = indmin(i) 
     901        indmax_required(i) = indmax(i) 
    765902! 
    766903!       Necessary for the Quadratic interpolation 
    767904! 
     905 
    768906        if ( (pttruetab(i) == cetruetab(i)) .and. (posvar(i) == 1) ) then 
     907            if (Agrif_UseSpecialValue) then 
     908               indmin(i) = indmin(i)-MaxSearch 
     909               indmax(i) = indmax(i)+MaxSearch 
     910            endif 
    769911        elseif ( coords(i) == 0 ) then  ! (interptab == 'N') 
    770912        elseif ( (type_interp(i) == Agrif_ppm)     .or.     & 
     
    772914                 (type_interp(i) == Agrif_ppm_lim) .or.     & 
    773915                 (type_interp(i) == Agrif_weno) ) then 
    774             indmin(i) = indmin(i) - 2 
    775             indmax(i) = indmax(i) + 2 
    776  
     916                  
     917            if ((mod(coeffraf,2) == 0).AND.(posvar(i)==2)) then 
     918             
     919              xpmax = s_Parent(i)+(indmax(i)-pttab_Parent(i))*ds_Parent(i) 
     920              if (xpmax > dim_newmax(i)+ds_Child(i)) then 
     921                indmax(i) = indmax(i) + 1 
     922              else 
     923                indmax(i) = indmax(i) + 2 
     924              endif 
     925               
     926              xpmin = s_Parent(i)+(indmin(i)-pttab_Parent(i))*ds_Parent(i) 
     927              if (xpmin < dim_newmin(i)-ds_Child(i)) then 
     928                indmin(i) = indmin(i) - 1 
     929              else 
     930                indmin(i) = indmin(i) - 2 
     931              endif 
     932               
     933            else 
     934              indmin(i) = indmin(i) - 2 
     935              indmax(i) = indmax(i) + 2 
     936            endif 
     937 
     938            indmin_required(i) = indmin(i) 
     939            indmax_required(i) = indmax(i) 
     940         
    777941            if (Agrif_UseSpecialValue) then 
    778942               indmin(i) = indmin(i)-MaxSearch 
    779943               indmax(i) = indmax(i)+MaxSearch 
    780944            endif 
    781  
     945        elseif (type_interp(i) == Agrif_linearconservlim) then 
     946         
     947            if ((mod(coeffraf,2) == 0).AND.(posvar(i)==2)) then 
     948             
     949              xpmax = s_Parent(i)+(indmax(i)-pttab_Parent(i))*ds_Parent(i) 
     950              if (xpmax > dim_newmax(i)+ds_Child(i)) then 
     951                indmax(i) = indmax(i) 
     952              else 
     953                indmax(i) = indmax(i) + 1 
     954              endif 
     955               
     956              xpmin = s_Parent(i)+(indmin(i)-pttab_Parent(i))*ds_Parent(i) 
     957              if (xpmin < dim_newmin(i)-ds_Child(i)) then 
     958                indmin(i) = indmin(i) 
     959              else 
     960                indmin(i) = indmin(i) - 1 
     961              endif 
     962               
     963            else 
     964              indmin(i) = indmin(i) - 1 
     965              indmax(i) = indmax(i) + 1 
     966            endif 
     967 
     968            indmin_required(i) = indmin(i) 
     969            indmax_required(i) = indmax(i) 
     970         
     971            if (Agrif_UseSpecialValue) then 
     972               indmin(i) = indmin(i)-MaxSearch 
     973               indmax(i) = indmax(i)+MaxSearch 
     974            endif 
     975             
    782976        elseif ( (type_interp(i) /= Agrif_constant) .and.   & 
    783977                 (type_interp(i) /= Agrif_linear) ) then 
    784978            indmin(i) = indmin(i) - 1 
    785979            indmax(i) = indmax(i) + 1 
     980             
     981            indmin_required(i) = indmin(i) 
     982            indmax_required(i) = indmax(i) 
    786983 
    787984            if (Agrif_UseSpecialValue) then 
     
    789986               indmax(i) = indmax(i)+MaxSearch 
    790987            endif 
    791  
    792988        elseif ( (type_interp(i) == Agrif_constant) .or.   & 
    793989                 (type_interp(i) == Agrif_linear) ) then 
     990            indmin_required(i) = indmin(i) 
     991            indmax_required(i) = indmax(i) 
    794992            if (Agrif_UseSpecialValue) then 
    795993               indmin(i) = indmin(i)-MaxSearch 
    796994               indmax(i) = indmax(i)+MaxSearch 
    797995            endif 
    798  
    799996        endif 
     997 
    800998! 
    801999    enddo 
     
    8221020    integer,            intent(in)  :: indmin, indmax 
    8231021    integer,            intent(in)  :: pttab_child, petab_child 
    824     real,               intent(in)  :: s_child, s_parent 
    825     real,               intent(in)  :: ds_child, ds_parent 
     1022    real(kind=8),               intent(in)  :: s_child, s_parent 
     1023    real(kind=8),               intent(in)  :: ds_child, ds_parent 
    8261024    real, dimension(            & 
    8271025        indmin:indmax           & 
     
    8571055    integer, dimension(2),              intent(in)  :: indmin, indmax 
    8581056    integer, dimension(2),              intent(in)  :: pttab_child, petab_child 
    859     real,    dimension(2),              intent(in)  :: s_child, s_parent 
    860     real,    dimension(2),              intent(in)  :: ds_child, ds_parent 
     1057    real(kind=8),    dimension(2),              intent(in)  :: s_child, s_parent 
     1058    real(kind=8),    dimension(2),              intent(in)  :: ds_child, ds_parent 
    8611059    real,    dimension(                 & 
    8621060        indmin(1):indmax(1),            & 
     
    8751073        indmin(2):indmax(2),            & 
    8761074        pttab_child(1):petab_child(1))  :: tabtemp_trsp 
    877     integer                             :: i, j, coeffraf 
     1075    integer                             :: i, j, coeffraf, locind_child_left, ideb 
    8781076!--------------------------------------------------------------------------------------------------- 
    8791077! 
     
    9001098                    s_parent(1),s_child(1),ds_parent(1),ds_child(1),1) 
    9011099!---CDIR NEXPAND 
    902         call PPM1dAfterCompute(tabin,tabtemp,size(tabin),size(tabtemp),1) 
     1100        call PPM1dAfterCompute(tabin,tabtemp,size(tabin),size(tabtemp),1,indchildppm(:,1),tabppm(:,:,1)) 
     1101    else if (coeffraf == 1) then 
     1102        locind_child_left = indmin(1) + agrif_int((s_child(1)-s_parent(1))/ds_parent(1)) 
     1103         
     1104            do j = indmin(2), indmax(2) 
     1105            ideb = locind_child_left 
     1106            do i = pttab_child(1), petab_child(1) 
     1107                tabtemp(i,j) = tabin(ideb,j) 
     1108                ideb = ideb + 1 
     1109            enddo 
     1110            enddo 
     1111 
    9031112    else 
    9041113        do j = indmin(2),indmax(2) 
     
    9411150!---CDIR NEXPAND 
    9421151        call PPM1dAfterCompute(tabtemp_trsp, tabout_trsp,    & 
    943                                size(tabtemp_trsp), size(tabout_trsp), 2) 
     1152                               size(tabtemp_trsp), size(tabout_trsp), 2, & 
     1153                              indchildppm(:,2),tabppm(:,:,2)) 
    9441154    else 
    9451155        do i = pttab_child(1), petab_child(1) 
     
    9761186    integer, dimension(3),              intent(in)  :: indmin, indmax 
    9771187    integer, dimension(3),              intent(in)  :: pttab_child, petab_child 
    978     real,    dimension(3),              intent(in)  :: s_child, s_parent 
    979     real,    dimension(3),              intent(in)  :: ds_child, ds_parent 
     1188    real(kind=8),    dimension(3),              intent(in)  :: s_child, s_parent 
     1189    real(kind=8),    dimension(3),              intent(in)  :: ds_child, ds_parent 
    9801190    real,    dimension(                 & 
    9811191        indmin(1):indmax(1),            & 
     
    9911201        pttab_child(2):petab_child(2),  & 
    9921202        indmin(3):indmax(3))            :: tabtemp 
    993     integer                             :: i, j, k, coeffraf 
     1203    integer                             :: i, j, k, coeffraf,kp,kp1,kp2,kp3,kp4,kref 
    9941204    integer                             :: locind_child_left, kdeb 
     1205    real(kind=8)    :: ypos,globind_parent_left 
     1206    real(kind=8)    :: deltax, invdsparent 
     1207    real    :: t2,t3,t4,t5,t6,t7,t8 
     1208    integer :: locind_parent_left 
     1209 
    9951210! 
    9961211    coeffraf = nint ( ds_parent(1) / ds_child(1) ) 
     
    10511266            enddo 
    10521267        enddo 
     1268    else if (type_interp(3) == Agrif_LAGRANGE) then 
     1269      invdsparent = 1./ds_parent(3) 
     1270      ypos = s_child(3) 
     1271      do k=pttab_child(3), petab_child(3) 
     1272        locind_parent_left = indmin(3)+agrif_int((ypos - s_parent(3))/ds_parent(3)) 
     1273        globind_parent_left = s_parent(3) + (locind_parent_left - indmin(3))*ds_parent(3) 
     1274        deltax = invdsparent*(ypos-globind_parent_left) 
     1275        deltax = nint(coeffraf*deltax)/real(coeffraf) 
     1276        ypos = ypos + ds_child(3) 
     1277 
     1278        if (abs(deltax) <= 0.0001) then 
     1279          do j = pttab_child(2), petab_child(2) 
     1280          do i = pttab_child(1), petab_child(1) 
     1281             tabout(i,j,k) = tabtemp(i,j,locind_parent_left) 
     1282          enddo 
     1283          enddo 
     1284        else 
     1285         t2 = deltax - 2. 
     1286        t3 = deltax - 1. 
     1287        t4 = deltax + 1. 
     1288 
     1289        t5 = -(1./6.)*deltax*t2*t3 
     1290        t6 = 0.5*t2*t3*t4 
     1291        t7 = -0.5*deltax*t2*t4 
     1292        t8 = (1./6.)*deltax*t3*t4       
     1293          do j = pttab_child(2), petab_child(2) 
     1294          do i = pttab_child(1), petab_child(1) 
     1295             tabout(i,j,k) = t5*tabtemp(i,j,locind_parent_left-1) + t6*tabtemp(i,j,locind_parent_left)    & 
     1296              +t7*tabtemp(i,j,locind_parent_left+1) + t8*tabtemp(i,j,locind_parent_left+2) 
     1297          enddo 
     1298          enddo 
     1299 
     1300        endif 
     1301 
     1302      enddo 
     1303    else if (type_interp(3) == Agrif_PPM) then 
     1304     call PPM1dPrecompute2d(1, & 
     1305                               indmax(3)-indmin(3)+1,           & 
     1306                               petab_child(3)-pttab_child(3)+1, & 
     1307                               s_parent(3),s_child(3),ds_parent(3),ds_child(3),1) 
     1308 
     1309     do k=pttab_child(3),petab_child(3) 
     1310        kref = k-pttab_child(3)+1 
     1311        kp=indmin(3)+indparentppm(kref,1)-1 
     1312        kp1 = kp + 1 
     1313        kp2 = kp1 + 1 
     1314        kp3 = kp2 + 1 
     1315        kp4 = kp3 + 1 
     1316        do j = pttab_child(2), petab_child(2) 
     1317        do i = pttab_child(1), petab_child(1) 
     1318         tabout(i,j,k) = tabppm(1,indchildppm(kref,1),1)*tabtemp(i,j,kp)   + & 
     1319                         tabppm(2,indchildppm(kref,1),1)*tabtemp(i,j,kp1)  + & 
     1320                         tabppm(3,indchildppm(kref,1),1)*tabtemp(i,j,kp2)  + & 
     1321                         tabppm(4,indchildppm(kref,1),1)*tabtemp(i,j,kp3)  + & 
     1322                         tabppm(5,indchildppm(kref,1),1)*tabtemp(i,j,kp4) 
     1323        enddo 
     1324        enddo 
     1325     enddo 
     1326 
    10531327    else 
     1328 
    10541329        do j = pttab_child(2), petab_child(2) 
    10551330        do i = pttab_child(1), petab_child(1) 
     
    10631338        enddo 
    10641339        enddo 
     1340 
    10651341    endif 
    10661342!--------------------------------------------------------------------------------------------------- 
     
    10831359    integer, dimension(4),              intent(in)  :: indmin, indmax 
    10841360    integer, dimension(4),              intent(in)  :: pttab_child, petab_child 
    1085     real,    dimension(4),              intent(in)  :: s_child, s_parent 
    1086     real,    dimension(4),              intent(in)  :: ds_child, ds_parent 
     1361    real(kind=8),    dimension(4),              intent(in)  :: s_child, s_parent 
     1362    real(kind=8),    dimension(4),              intent(in)  :: ds_child, ds_parent 
    10871363    real,    dimension(                 & 
    10881364        indmin(1):indmax(1),            & 
     
    11021378        indmin(4):indmax(4))            :: tabtemp 
    11031379    integer                             :: i, j, k, l 
     1380 
     1381    real(kind=8)    :: ypos,globind_parent_left 
     1382    real(kind=8)    :: deltax, invdsparent 
     1383    real    :: t2,t3,t4,t5,t6,t7,t8 
     1384    integer :: locind_parent_left, coeffraf 
    11041385! 
    11051386    do l = indmin(4), indmax(4) 
     
    11171398    enddo 
    11181399! 
     1400     if (type_interp(4) == Agrif_LAGRANGE) then 
     1401      coeffraf = nint(ds_parent(4)/ds_child(4)) 
     1402      invdsparent = 1./ds_parent(4) 
     1403      ypos = s_child(4) 
     1404      do l=pttab_child(4), petab_child(4) 
     1405        locind_parent_left = indmin(4)+agrif_int((ypos - s_parent(4))/ds_parent(4)) 
     1406        globind_parent_left = s_parent(4) + (locind_parent_left - indmin(4))*ds_parent(4) 
     1407        deltax = invdsparent*(ypos-globind_parent_left) 
     1408        deltax = nint(coeffraf*deltax)/real(coeffraf) 
     1409        ypos = ypos + ds_child(4) 
     1410 
     1411        if (abs(deltax) <= 0.0001) then 
     1412          do k = pttab_child(3), petab_child(3) 
     1413          do j = pttab_child(2), petab_child(2) 
     1414          do i = pttab_child(1), petab_child(1) 
     1415             tabout(i,j,k,l) = tabtemp(i,j,k,locind_parent_left) 
     1416          enddo 
     1417          enddo 
     1418          enddo 
     1419        else 
     1420         t2 = deltax - 2. 
     1421        t3 = deltax - 1. 
     1422        t4 = deltax + 1. 
     1423 
     1424        t5 = -(1./6.)*deltax*t2*t3 
     1425        t6 = 0.5*t2*t3*t4 
     1426        t7 = -0.5*deltax*t2*t4 
     1427        t8 = (1./6.)*deltax*t3*t4       
     1428          do k = pttab_child(3), petab_child(3) 
     1429          do j = pttab_child(2), petab_child(2) 
     1430          do i = pttab_child(1), petab_child(1) 
     1431             tabout(i,j,k,l) = t5*tabtemp(i,j,k,locind_parent_left-1) + t6*tabtemp(i,j,k,locind_parent_left)    & 
     1432              +t7*tabtemp(i,j,k,locind_parent_left+1) + t8*tabtemp(i,j,k,locind_parent_left+2) 
     1433          enddo 
     1434          enddo 
     1435          enddo 
     1436        endif 
     1437 
     1438      enddo 
     1439    else 
    11191440    do k = pttab_child(3), petab_child(3) 
    11201441    do j = pttab_child(2), petab_child(2) 
     
    11301451    enddo 
    11311452    enddo 
     1453    endif 
    11321454!--------------------------------------------------------------------------------------------------- 
    11331455end subroutine Agrif_Interp_4D_recursive 
     
    11491471    integer, dimension(5),              intent(in)  :: indmin, indmax 
    11501472    integer, dimension(5),              intent(in)  :: pttab_child, petab_child 
    1151     real,    dimension(5),              intent(in)  :: s_child, s_parent 
    1152     real,    dimension(5),              intent(in)  :: ds_child, ds_parent 
     1473    real(kind=8),    dimension(5),              intent(in)  :: s_child, s_parent 
     1474    real(kind=8),    dimension(5),              intent(in)  :: ds_child, ds_parent 
    11531475    real,    dimension(                 & 
    11541476        indmin(1):indmax(1),            & 
     
    12221544    integer, dimension(6),                  intent(in)  :: indmin, indmax 
    12231545    integer, dimension(6),                  intent(in)  :: pttab_child, petab_child 
    1224     real,    dimension(6),                  intent(in)  :: s_child, s_parent 
    1225     real,    dimension(6),                  intent(in)  :: ds_child, ds_parent 
     1546    real(kind=8),    dimension(6),                  intent(in)  :: s_child, s_parent 
     1547    real(kind=8),    dimension(6),                  intent(in)  :: ds_child, ds_parent 
    12261548    real,    dimension(                 & 
    12271549        indmin(1):indmax(1),            & 
     
    13011623    REAL, DIMENSION(indmin:indmax),           INTENT(IN)    :: parenttab 
    13021624    REAL, DIMENSION(pttab_child:petab_child), INTENT(OUT)   :: childtab 
    1303     REAL                                                    :: s_parent, s_child 
    1304     REAL                                                    :: ds_parent,ds_child 
     1625    REAL(kind=8)                                            :: s_parent, s_child 
     1626    REAL(kind=8)                                            :: ds_parent,ds_child 
    13051627! 
    13061628    if ( (indmin == indmax) .and. (pttab_child == petab_child) ) then 
     
    13711693!--------------------------------------------------------------------------------------------------- 
    13721694function Agrif_Find_list_interp ( list_interp, pttab, petab, pttab_Child, pttab_Parent,     & 
    1373                                     nbdim, indmin, indmax, indminglob,  indmaxglob,         & 
     1695                                    nbdim, indmin, indmax, indmin_required_p, indmax_required_p, & 
     1696                                    indminglob,  indmaxglob,         & 
    13741697                                    pttruetab, cetruetab, memberin                          & 
    13751698#if defined AGRIF_MPI 
     
    13821705    integer,                       intent(in)  :: nbdim 
    13831706    integer, dimension(nbdim),     intent(in)  :: pttab, petab, pttab_Child, pttab_Parent 
    1384     integer, dimension(nbdim),     intent(out) :: indmin, indmax 
     1707    integer, dimension(nbdim),     intent(out) :: indmin, indmax, indmin_required_p, indmax_required_p 
    13851708    integer, dimension(nbdim),     intent(out) :: indminglob, indmaxglob 
    13861709    integer, dimension(nbdim),     intent(out) :: pttruetab, cetruetab 
     
    14211744        indmin = pil % indmin(1:nbdim) 
    14221745        indmax = pil % indmax(1:nbdim) 
     1746        indmin_required_p = pil % indmin_required_p(1:nbdim) 
     1747        indmax_required_p = pil % indmax_required_p(1:nbdim) 
    14231748 
    14241749        pttruetab = pil % pttruetab(1:nbdim) 
     
    14521777!--------------------------------------------------------------------------------------------------- 
    14531778subroutine Agrif_AddTo_list_interp ( list_interp, pttab, petab, pttab_Child, pttab_Parent,  & 
    1454                                      indmin, indmax, indminglob, indmaxglob,                & 
     1779                                     indmin, indmax, indmin_required_p, indmax_required_p,  & 
     1780                                     indminglob, indmaxglob,                & 
    14551781                                     pttruetab, cetruetab,                                  & 
    14561782                                     memberin, nbdim                                        & 
     
    14661792    integer                                 :: nbdim 
    14671793    integer, dimension(nbdim)               :: pttab, petab, pttab_Child, pttab_Parent 
    1468     integer, dimension(nbdim)               :: indmin,indmax 
     1794    integer, dimension(nbdim)               :: indmin,indmax, indmin_required_p, indmax_required_p 
    14691795    integer, dimension(nbdim)               :: indminglob, indmaxglob 
    14701796    integer, dimension(nbdim)               :: pttruetab, cetruetab 
     
    14951821    pil % indmin(1:nbdim) = indmin(1:nbdim) 
    14961822    pil % indmax(1:nbdim) = indmax(1:nbdim) 
     1823 
     1824    pil % indmin_required_p(1:nbdim) = indmin_required_p(1:nbdim) 
     1825    pil % indmax_required_p(1:nbdim) = indmax_required_p(1:nbdim) 
    14971826 
    14981827    pil % memberin = memberin 
  • vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modinterpbasic.F90

    r5656 r10087  
    4141    integer, dimension(:), allocatable      :: indparentppm_1d, indchildppm_1d 
    4242! 
     43 
    4344    private :: Agrif_limiter_vanleer 
    4445! 
     
    5657    integer,             intent(in)     :: np           !< Length of input array 
    5758    integer,             intent(in)     :: nc           !< Length of output array 
    58     real,                intent(in)     :: s_parent     !< Parent grid position (s_root = 0) 
    59     real,                intent(in)     :: s_child      !< Child  grid position (s_root = 0) 
    60     real,                intent(in)     :: ds_parent    !< Parent grid dx (ds_root = 1) 
    61     real,                intent(in)     :: ds_child     !< Child  grid dx (ds_root = 1) 
     59    real(kind=8),                intent(in)     :: s_parent     !< Parent grid position (s_root = 0) 
     60    real(kind=8),                intent(in)     :: s_child      !< Child  grid position (s_root = 0) 
     61    real(kind=8),                intent(in)     :: ds_parent    !< Parent grid dx (ds_root = 1) 
     62    real(kind=8),                intent(in)     :: ds_child     !< Child  grid dx (ds_root = 1) 
    6263! 
    6364    integer :: i, coeffraf, locind_parent_left 
    64     real    :: globind_parent_left, globind_parent_right 
    65     real    :: invds, invds2, ypos, ypos2, diff 
     65    real(kind=8)    :: globind_parent_left, globind_parent_right 
     66    real(kind=8)    :: invds, invds2, ypos, ypos2, diff 
    6667! 
    6768    coeffraf = nint(ds_parent/ds_child) 
     
    9293! 
    9394        diff = globind_parent_right - ypos2 
     95! quick fix for roundoff error 
     96        diff=nint(diff*coeffraf)/real(coeffraf) 
     97 
    9498        y(i) = (diff*x(locind_parent_left) + (1.-diff)*x(locind_parent_left+1)) 
     99 
    95100        ypos2 = ypos2 + invds2 
    96101! 
     
    104109    else 
    105110        globind_parent_left = s_parent + (locind_parent_left - 1)*ds_parent 
    106         y(nc) = ((globind_parent_left + ds_parent - ypos)*x(locind_parent_left)  & 
    107                            + (ypos - globind_parent_left)*x(locind_parent_left+1))*invds 
    108     endif 
     111        diff=(globind_parent_left + ds_parent - ypos)*invds 
     112 
     113! quick fix for roundoff error 
     114        diff=nint(diff*coeffraf)/real(coeffraf) 
     115!        y(nc) = ((globind_parent_left + ds_parent - ypos)*x(locind_parent_left)  & 
     116!                           + (ypos - globind_parent_left)*x(locind_parent_left+1))*invds 
     117        y(nc) = (diff*x(locind_parent_left) + (1.-diff)*x(locind_parent_left+1)) 
     118    endif 
     119 
    109120!--------------------------------------------------------------------------------------------------- 
    110121end subroutine Agrif_basicinterp_linear1D 
     
    120131!--------------------------------------------------------------------------------------------------- 
    121132    integer, intent(in) :: np,nc,np2 
    122     real,    intent(in) :: s_parent, s_child 
    123     real,    intent(in) :: ds_parent, ds_child 
     133    real(kind=8),    intent(in) :: s_parent, s_child 
     134    real(kind=8),    intent(in) :: ds_parent, ds_child 
    124135    integer, intent(in) :: dir 
    125136! 
     
    127138    integer, dimension(:,:), allocatable :: indparent_tmp 
    128139    real, dimension(:,:), allocatable :: coeffparent_tmp 
    129     real    :: ypos,globind_parent_left,globind_parent_right 
    130     real    :: invds, invds2, invds3 
    131     real :: ypos2,diff 
     140    real(kind=8)    :: ypos,globind_parent_left,globind_parent_right 
     141    real(kind=8)    :: invds, invds2, invds3 
     142    real(kind=8) :: ypos2,diff 
    132143! 
    133144    coeffraf = nint(ds_parent/ds_child) 
     
    164175        if (ypos2 > globind_parent_right) then 
    165176            locind_parent_left = locind_parent_left + 1 
    166             globind_parent_right = globind_parent_right + 1. 
     177            globind_parent_right = globind_parent_right + 1.d0 
    167178            ypos2 = ypos*invds+(i-1)*invds2 
    168179        endif 
     
    239250    real, dimension(np), intent(in)     :: x 
    240251    real, dimension(nc), intent(out)    :: y 
    241     real,                intent(in)     :: s_parent, s_child 
    242     real,                intent(in)     :: ds_parent, ds_child 
     252    real(kind=8),                intent(in)     :: s_parent, s_child 
     253    real(kind=8),                intent(in)     :: ds_parent, ds_child 
    243254! 
    244255    integer :: i, coeffraf, locind_parent_left 
    245     real    :: ypos,globind_parent_left 
    246     real    :: deltax, invdsparent 
     256    real(kind=8)    :: ypos,globind_parent_left 
     257    real(kind=8)    :: deltax, invdsparent 
    247258    real    :: t2,t3,t4,t5,t6,t7,t8 
    248259! 
     
    304315    real, dimension(np), intent(in)     :: x 
    305316    real, dimension(nc), intent(out)    :: y 
    306     real,                intent(in)     :: s_parent, s_child 
    307     real,                intent(in)     :: ds_parent, ds_child 
     317    real(kind=8),                intent(in)     :: s_parent, s_child 
     318    real(kind=8),                intent(in)     :: ds_parent, ds_child 
    308319! 
    309320    integer :: i, coeffraf, locind_parent 
    310     real    :: ypos 
     321    real(kind=8)    :: ypos 
    311322! 
    312323    coeffraf = nint(ds_parent/ds_child) 
     
    342353    real, dimension(np), intent(in)     :: x 
    343354    real, dimension(nc), intent(out)    :: y 
    344     real,                intent(in)     :: s_parent, s_child 
    345     real,                intent(in)     :: ds_parent, ds_child 
     355    real(kind=8),                intent(in)     :: s_parent, s_child 
     356    real(kind=8),                intent(in)     :: ds_parent, ds_child 
    346357! 
    347358    real, dimension(:), allocatable :: ytemp 
    348359    integer :: i,coeffraf,locind_parent_left,locind_parent_last 
    349     real    :: ypos,xdiffmod,xpmin,xpmax,slope 
     360    real(kind=8)    :: ypos,xdiffmod,xpmin,xpmax,slope 
    350361    integer :: i1,i2,ii 
    351362    integer :: diffmod 
     
    429440    real, dimension(np), intent(in)     :: x 
    430441    real, dimension(nc), intent(out)    :: y 
    431     real,                intent(in)     :: s_parent, s_child 
    432     real,                intent(in)     :: ds_parent, ds_child 
     442    real(kind=8),                intent(in)     :: s_parent, s_child 
     443    real(kind=8),                intent(in)     :: ds_parent, ds_child 
    433444! 
    434445    real, dimension(:), allocatable :: ytemp 
    435446    integer :: i,coeffraf,locind_parent_left,locind_parent_last 
    436     real    :: ypos,xdiffmod,xpmin,xpmax,slope 
     447    real(kind=8)    :: ypos,xdiffmod,xpmin,xpmax,slope 
    437448    integer :: i1,i2,ii 
    438449    integer :: diffmod 
     
    524535    real, dimension(np), intent(in)     :: x 
    525536    real, dimension(nc), intent(out)    :: y 
    526     real,                intent(in)     :: s_parent, s_child 
    527     real,                intent(in)     :: ds_parent, ds_child 
     537    real(kind=8),                intent(in)     :: s_parent, s_child 
     538    real(kind=8),                intent(in)     :: ds_parent, ds_child 
    528539! 
    529540    integer :: i,coeffraf,locind_parent_left,locind_parent_last 
    530541    integer :: iparent,ipos,pos,nmin,nmax 
    531     real    :: ypos 
     542    real(kind=8)    :: ypos 
    532543    integer :: i1,jj 
    533     real :: xpmin,a 
     544    real(kind=8) :: xpmin 
     545    real :: a 
    534546! 
    535547    real, dimension(np) :: xl,delta,a6,slope 
     
    646658!--------------------------------------------------------------------------------------------------- 
    647659    integer,             intent(in)     :: np2, np, nc 
    648     real,                intent(in)     :: s_parent, s_child 
    649     real,                intent(in)     :: ds_parent, ds_child 
     660    real(kind=8),                intent(in)     :: s_parent, s_child 
     661    real(kind=8),                intent(in)     :: ds_parent, ds_child 
    650662    integer,             intent(in)     :: dir 
    651663! 
     
    655667    integer :: iparent,ipos,pos 
    656668    real    :: ypos 
    657     integer :: i1,jj 
    658     real :: xpmin,a 
     669    integer :: i1,jj,k,l,j 
     670    real(kind=8) :: xpmin 
     671    real :: a 
    659672! 
    660673    integer :: diffmod 
     
    738751    enddo 
    739752! 
    740     do i = 1,np2 
    741         indparentppm(1+(i-1)*nc:i*nc,dir) = indparentppm_1d(1:nc) + (i-1)*np 
    742         indchildppm (1+(i-1)*nc:i*nc,dir) = indchildppm_1d (1:nc) 
     753 
     754    k=1 
     755    l=0 
     756    do i=1,np2 
     757      do j=1,nc 
     758        indchildppm(k,dir) = indchildppm_1d(j) 
     759        indparentppm(k,dir) = indparentppm_1d(j) + l 
     760        k=k+1 
     761      enddo 
     762      l=l+np 
    743763    enddo 
    744764!--------------------------------------------------------------------------------------------------- 
     
    746766!=================================================================================================== 
    747767! 
    748 !=================================================================================================== 
    749 !subroutine PPM1dPrecompute(np,nc,& 
    750 !                    s_parent,s_child,ds_parent,ds_child) 
    751 !! 
    752 !!CC   Description: 
    753 !!CC   subroutine to compute coefficient and index for  a 1D interpolation 
    754 !!CC   using piecewise parabolic method 
    755 !!C    Method: 
    756 !! 
    757 !!     Declarations: 
    758 !! 
    759 !      Implicit none 
    760 !! 
    761 !!     Arguments 
    762 !      Integer             :: np,nc 
    763 !!      Real, Dimension(:),Allocatable :: ytemp 
    764 !      Real                :: s_parent,s_child,ds_parent,ds_child 
    765 !! 
    766 !!     Local scalars 
    767 !      Integer :: i,coeffraf,locind_parent_left,locind_parent_last 
    768 !      Integer :: iparent,ipos,pos,nmin,nmax 
    769 !      Real    :: ypos 
    770 !      integer :: i1,jj 
    771 !      Real :: xpmin,a 
    772 !! 
    773 !      Real :: xrmin,xrmax,am3,s2,s1 
    774 !      Real, Dimension(np) :: xl,delta,a6,slope 
    775 !!      Real, Dimension(:),Allocatable  :: diff,diff2,diff3 
    776 !      INTEGER :: diffmod 
    777 !      REAL :: invcoeffraf 
    778 !! 
    779 !      coeffraf = nint(ds_parent/ds_child) 
    780 !! 
    781 !      If (coeffraf == 1) Then 
    782 !          return 
    783 !      End If 
    784 !      invcoeffraf = ds_child/ds_parent 
    785 !! 
    786 ! 
    787 !      if (.not.allocated(indparentppm)) then 
    788 !      allocate(indparentppm(-2*coeffraf:nc+2*coeffraf,1),& 
    789 !         indchildppm(-2*coeffraf:nc+2*coeffraf,1)) 
    790 !      else 
    791 !      if (size(indparentppm,1)<nc+4*coeffraf+1) then 
    792 !      deallocate(indparentppm,indchildppm) 
    793 !      allocate(indparentppm(-2*coeffraf:nc+2*coeffraf,1),& 
    794 !         indchildppm(-2*coeffraf:nc+2*coeffraf,1)) 
    795 !      endif 
    796 !      endif 
    797 ! 
    798 !      ypos = s_child 
    799 !! 
    800 !      locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent) 
    801 !      locind_parent_last = 1 +& 
    802 !      agrif_ceiling((ypos +(nc - 1)& 
    803 !      *ds_child - s_parent)/ds_parent) 
    804 !! 
    805 !      xpmin = s_parent + (locind_parent_left-1)*ds_parent 
    806 !      i1 = 1+agrif_int((xpmin-s_child)/ds_child) 
    807 !! 
    808 !! 
    809 ! 
    810 !      Do i=1,coeffraf 
    811 !        tabdiff2(i)=(real(i)-0.5)*invcoeffraf 
    812 !      EndDo 
    813 ! 
    814 !      a = invcoeffraf**2 
    815 !      tabdiff3(1) = (1./3.)*a 
    816 !      a=2.*a 
    817 !!CDIR ALTCODE 
    818 !!!!CDIR SHORTLOOP 
    819 !      Do i=2,coeffraf 
    820 !        tabdiff3(i) = tabdiff3(i-1)+(real(i)-1)*a 
    821 !      EndDo 
    822 ! 
    823 !!CDIR ALTCODE 
    824 !!!!CDIR SHORTLOOP 
    825 !      Do i=1,coeffraf 
    826 !      tabppm(1,i,1) = 0.08333333333333*(-1.+4*tabdiff2(i)-3*tabdiff3(i)) 
    827 !      tabppm(2,i,1) = 0.08333333333333*& 
    828 !              (7.-26.*tabdiff2(i)+18.*tabdiff3(i)) 
    829 !      tabppm(3,i,1) =0.08333333333333*(7.+30*tabdiff2(i)-30*tabdiff3(i)) 
    830 !      tabppm(4,i,1) = 0.08333333333333*& 
    831 !              (-1.-10.*tabdiff2(i)+18.*tabdiff3(i)) 
    832 !      tabppm(5,i,1) = 0.08333333333333*(2*tabdiff2(i)-3*tabdiff3(i)) 
    833 !      End Do 
    834 !! 
    835 !! 
    836 !        diffmod = 0 
    837 !       IF (mod(coeffraf,2) == 0) diffmod = 1 
    838 !! 
    839 !        ipos = i1 
    840 !! 
    841 !        Do iparent = locind_parent_left,locind_parent_last 
    842 !             pos=1 
    843 !!CDIR ALTCODE 
    844 !!CDIR SHORTLOOP 
    845 !             Do jj = ipos - coeffraf/2+diffmod,ipos + coeffraf/2 
    846 !         indparentppm(jj,1) = iparent-2 
    847 !         indchildppm(jj,1) = pos 
    848 !               pos = pos+1 
    849 !             End do 
    850 !             ipos = ipos + coeffraf 
    851 !! 
    852 !        End do 
    853 ! 
    854 !      Return 
    855 !      End subroutine ppm1dprecompute 
     768 
    856769!=================================================================================================== 
    857770! 
     
    863776! Use precomputed coefficient and index. 
    864777!--------------------------------------------------------------------------------------------------- 
    865 subroutine PPM1dAfterCompute ( x, y, np, nc, dir ) 
    866 !--------------------------------------------------------------------------------------------------- 
     778subroutine PPM1dAfterCompute ( x, y, np, nc, dir, indchildppmloc, tabppmloc ) 
     779!--------------------------------------------------------------------------------------------------- 
     780    integer,             intent(in)     :: np, nc 
    867781    real, dimension(np), intent(in)     :: x 
    868782    real, dimension(nc), intent(out)    :: y 
    869     integer,             intent(in)     :: np, nc 
    870783    integer,             intent(in)     :: dir 
    871 ! 
    872     integer :: i 
    873 ! 
     784    integer, dimension(1:),intent(in) :: indchildppmloc 
     785    real, dimension(1:,1:),intent(in) :: tabppmloc 
     786! 
     787    integer :: i,j,jp1,jp2,jp3,jp4,k 
     788 
     789     
    874790    do i = 1,nc 
    875         y(i) = tabppm(1,indchildppm(i,dir),dir) * x(indparentppm(i,dir)  ) + & 
    876                tabppm(2,indchildppm(i,dir),dir) * x(indparentppm(i,dir)+1) + & 
    877                tabppm(3,indchildppm(i,dir),dir) * x(indparentppm(i,dir)+2) + & 
    878                tabppm(4,indchildppm(i,dir),dir) * x(indparentppm(i,dir)+3) + & 
    879                tabppm(5,indchildppm(i,dir),dir) * x(indparentppm(i,dir)+4) 
    880     enddo 
     791        j = indparentppm(i,dir) 
     792        jp1=j+1 
     793        jp2=jp1+1 
     794        jp3=jp2+1 
     795        jp4=jp3+1 
     796        y(i) = tabppmloc(1,indchildppmloc(i)) * x(j) + & 
     797               tabppmloc(2,indchildppmloc(i)) * x(jp1) + & 
     798               tabppmloc(3,indchildppmloc(i)) * x(jp2) + & 
     799               tabppmloc(4,indchildppmloc(i)) * x(jp3) + & 
     800               tabppmloc(5,indchildppmloc(i)) * x(jp4) 
     801    enddo 
     802 
    881803!--------------------------------------------------------------------------------------------------- 
    882804end subroutine PPM1dAfterCompute 
     805 
    883806!=================================================================================================== 
    884807! 
     
    1069992    real, dimension(np), intent(in)     :: x 
    1070993    real, dimension(nc), intent(out)    :: y 
    1071     real,                intent(in)     :: s_parent, s_child 
    1072     real,                intent(in)     :: ds_parent, ds_child 
     994    real(kind=8),                intent(in)     :: s_parent, s_child 
     995    real(kind=8),                intent(in)     :: ds_parent, ds_child 
    1073996! 
    1074997    real, dimension(:), allocatable :: ytemp 
    1075998    integer :: i,coeffraf,locind_parent_left,locind_parent_last 
    1076999    integer :: iparent,ipos,pos,nmin,nmax 
    1077     real    :: ypos 
     1000    real(kind=8)    :: ypos 
    10781001    integer :: i1,jj 
    1079     real :: xpmin 
     1002    real(kind=8) :: xpmin 
    10801003! 
    10811004    real, dimension(np) :: slope 
     
    11661089    real, dimension(np), intent(in)     :: x 
    11671090    real, dimension(nc), intent(out)    :: y 
    1168     real,                intent(in)     :: s_parent, s_child 
    1169     real,                intent(in)     :: ds_parent, ds_child 
     1091    real(kind=8),                intent(in)     :: s_parent, s_child 
     1092    real(kind=8),                intent(in)     :: ds_parent, ds_child 
    11701093! 
    11711094    integer :: i,coeffraf,locind_parent_left,locind_parent_last 
    11721095    integer :: ipos, pos 
    1173     real    :: ypos,xi 
     1096    real(kind=8)    :: ypos,xi 
    11741097    integer :: i1,jj 
    1175     real :: xpmin 
     1098    real(kind=8) :: xpmin 
    11761099! 
    11771100    real, dimension(:),   allocatable  :: ytemp 
     
    12761199      Real, Dimension(nc) :: y 
    12771200      Real, Dimension(:),Allocatable :: ytemp 
    1278       Real                :: s_parent,s_child,ds_parent,ds_child 
     1201      Real(kind=8)        :: s_parent,s_child,ds_parent,ds_child 
    12791202! 
    12801203!     Local scalars 
    12811204      Integer :: i,coeffraf,locind_parent_left,locind_parent_last 
    12821205      Integer :: iparent,ipos,pos,nmin,nmax 
    1283       Real    :: ypos 
     1206      Real(kind=8)    :: ypos 
    12841207      integer :: i1,jj 
    1285       Real :: xpmin,cavg,a,b 
     1208      Real(kind=8) :: xpmin 
     1209      real :: cavg,a,b 
    12861210!       
    12871211      Real :: xrmin,xrmax,am3,s2,s1   
  • vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modlinktomodel.F90

    r5656 r10087  
    8080!                    Agrif_Curgrid % spaceref(1) 
    8181!=================================================================================================== 
    82 !  function Agrif_Parent_Irhox 
    83 !        modify by conv. To use : var = Agrif_Parent_IRhox() 
    84 !                    Agrif_Curgrid % parent % spaceref(1) 
    85 !=================================================================================================== 
    8682!  function Agrif_Rhoy 
    8783!        modify by conv. To use : var = Agrif_Rhoy() 
     
    9692!                    Agrif_Curgrid % spaceref(2) 
    9793!=================================================================================================== 
    98 !  function Agrif_Parent_Irhoy 
    99 !        modify by conv. To use : var = Agrif_Parent_IRhoy() 
    100 !                    Agrif_Curgrid % parent % spaceref(2) 
     94 
     95 
    10196!=================================================================================================== 
    10297!  function Agrif_Rhoz 
     
    111106!        modify by conv. To use : var = Agrif_Parent_IRhoz() 
    112107!                    Agrif_Curgrid % spaceref(3) 
    113 !=================================================================================================== 
    114 !  function Agrif_Parent_Irhoz 
    115 !        modify by conv. To use : var = Agrif_Parent_IRhoz() 
    116 !                    Agrif_Curgrid % parent % spaceref(3) 
     108 
    117109!=================================================================================================== 
    118110!  function Agrif_NearCommonBorderX 
  • vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modmask.F90

    r5656 r10087  
    4040!! when this one is equal to Agrif_SpecialValue. 
    4141!--------------------------------------------------------------------------------------------------- 
    42 subroutine Agrif_CheckMasknD ( tempP, parent, pbtab, petab, ppbtab, ppetab, noraftab, nbdim ) 
     42subroutine Agrif_CheckMasknD ( tempP, parent, pbtab, petab, ppbtab, ppetab, & 
     43             pbtab_required, petab_required, noraftab, nbdim ) 
    4344!--------------------------------------------------------------------------------------------------- 
    4445    type(Agrif_Variable), pointer   :: tempP  !< Part of the parent grid used for the interpolation of the child grid 
     
    4647    integer, dimension(nbdim)       :: pbtab  !< limits of the parent grid used 
    4748    integer, dimension(nbdim)       :: petab  !< interpolation of the child grid 
    48     integer, dimension(nbdim)       :: ppbtab, ppetab 
     49    integer, dimension(nbdim)       :: ppbtab, ppetab, pbtab_required, petab_required 
    4950    logical, dimension(nbdim)       :: noraftab 
    5051    integer                         :: nbdim 
    5152! 
    52     integer :: i0,j0,k0,l0,m0,n0 
     53    integer :: i0,j0,k0,l0,m0,n0,ll,kk 
     54    integer,dimension(:,:),allocatable :: trytoreplace 
     55    integer :: ilook, Nbvals 
     56    real :: xold 
    5357! 
    5458    select case (nbdim) 
     
    7781                    parent%array3(ppbtab(1),ppbtab(2),ppbtab(3)), & 
    7882                    ppbtab,ppetab,noraftab,MaxSearch,Agrif_SpecialValue) 
    79  
    80 !            Call CalculNewValTempP((/i0,j0,k0/), 
    81 !     &                             tempP,parent, 
    82 !     &                             ppbtab,ppetab, 
    83 !     &                             noraftab,nbdim) 
    84  
    8583            endif 
    8684        enddo 
     
    8886        enddo 
    8987    case (4) 
    90         do l0 = pbtab(4),petab(4) 
    91         do k0 = pbtab(3),petab(3) 
    92         do j0 = pbtab(2),petab(2) 
    93         do i0 = pbtab(1),petab(1) 
     88 
     89        if (noraftab(1).AND.noraftab(2)) then 
     90          allocate(trytoreplace(pbtab_required(3):petab_required(3),pbtab_required(4):petab_required(4))) 
     91          trytoreplace = -1 
     92          i0 = pbtab_required(1) 
     93          j0 = pbtab_required(2) 
     94          do l0 = pbtab_required(4),petab_required(4) 
     95          do k0 = pbtab_required(3),petab_required(3) 
    9496            if (tempP%array4(i0,j0,k0,l0) == Agrif_SpecialValue) then 
    9597                call CalculNewValTempP4D((/i0,j0,k0,l0/), & 
    9698                    tempP%array4(ppbtab(1),ppbtab(2),ppbtab(3),ppbtab(4)),  & 
    9799                    parent%array4(ppbtab(1),ppbtab(2),ppbtab(3),ppbtab(4)), & 
    98                     ppbtab,ppetab,noraftab,MaxSearch,Agrif_SpecialValue) 
    99             endif 
    100         enddo 
    101         enddo 
    102         enddo 
    103         enddo 
     100                    ppbtab,ppetab,noraftab,MaxSearch,Agrif_SpecialValue, & 
     101                    trytoreplace(k0,l0)) 
     102            endif 
     103          enddo 
     104          enddo 
     105 
     106          do l0 = pbtab_required(4),petab_required(4) 
     107          do k0 = pbtab_required(3),petab_required(3) 
     108          if (trytoreplace(k0,l0) /= -1) then 
     109          do j0 = pbtab_required(2),petab_required(2) 
     110          do i0 = pbtab_required(1),petab_required(1) 
     111 
     112          if (tempP%array4(i0,j0,k0,l0) == Agrif_SpecialValue) then 
     113          tempP%array4(i0,j0,k0,l0) = 0. 
     114          Nbvals = 0 
     115          do ll=max(l0-trytoreplace(k0,l0),ppbtab(4)),min(l0+trytoreplace(k0,l0),ppetab(4)) 
     116          do kk=max(k0-trytoreplace(k0,l0),ppbtab(3)),min(k0+trytoreplace(k0,l0),ppetab(3)) 
     117           if (parent%array4(i0,j0,kk,ll) /= Agrif_SpecialValue) then 
     118             tempP%array4(i0,j0,k0,l0) = tempP%array4(i0,j0,k0,l0) + parent%array4(i0,j0,kk,ll) 
     119             Nbvals = Nbvals + 1 
     120           endif 
     121          enddo 
     122          enddo 
     123 
     124          tempP%array4(i0,j0,k0,l0) = tempP%array4(i0,j0,k0,l0) /Nbvals 
     125          endif 
     126          enddo 
     127          enddo 
     128          endif 
     129          enddo 
     130          enddo 
     131          deallocate(trytoreplace) 
     132 
     133        else 
     134 
     135        do l0 = pbtab_required(4),petab_required(4) 
     136        do k0 = pbtab_required(3),petab_required(3) 
     137        do j0 = pbtab_required(2),petab_required(2) 
     138        do i0 = pbtab_required(1),petab_required(1) 
     139            if (tempP%array4(i0,j0,k0,l0) == Agrif_SpecialValue) then 
     140                ilook = -1 
     141                call CalculNewValTempP4D((/i0,j0,k0,l0/), & 
     142                    tempP%array4(ppbtab(1),ppbtab(2),ppbtab(3),ppbtab(4)),  & 
     143                    parent%array4(ppbtab(1),ppbtab(2),ppbtab(3),ppbtab(4)), & 
     144                    ppbtab,ppetab,noraftab,MaxSearch,Agrif_SpecialValue,ilook) 
     145            endif 
     146        enddo 
     147        enddo 
     148        enddo 
     149        enddo 
     150 
     151        endif 
    104152    case (5) 
    105153        do m0 = pbtab(5),petab(5) 
     
    488536!--------------------------------------------------------------------------------------------------- 
    489537subroutine CalculNewValTempP4D ( indic, tempP, parent, ppbtab, ppetab, noraftab, & 
    490                                  MaxSearch, Agrif_SpecialValue ) 
     538                                 MaxSearch, Agrif_SpecialValue, ilook ) 
    491539!--------------------------------------------------------------------------------------------------- 
    492540    integer, parameter          :: nbdim = 4 
     
    511559! 
    512560    logical                     :: firsttest 
     561    integer :: ilook 
    513562! 
    514563    ValMax = 1 
     
    528577    firsttest = .TRUE. 
    529578    idecal = indic 
     579 
     580    if (ilook /= -1) then 
     581       i = ilook 
     582    else 
     583       i = 1 
     584    endif 
    530585! 
    531586    do while (i <= ValMax) 
    532587! 
    533         if ((i == 1).AND.(firsttest)) i = Valmax 
     588!        if ((i == 1).AND.(firsttest)) i = Valmax 
    534589 
    535590        do iii = 1,nbdim 
     
    537592                imin(iii) = max(indic(iii) - i,ppbtab(iii)) 
    538593                imax(iii) = min(indic(iii) + i,ppetab(iii)) 
    539                 if (firsttest) then 
    540                     if (indic(iii) > ppbtab(iii)) then 
    541                         idecal(iii) = idecal(iii)-1 
    542                         if (tempP(idecal(1),idecal(2),idecal(3),idecal(4)) == Agrif_SpecialValue) then 
    543                             imin(iii) = imax(iii) 
    544                         endif 
    545                         idecal(iii) = idecal(iii)+1 
    546                     endif 
    547                 endif 
     594 !               if (firsttest) then 
     595 !                   if (indic(iii) > ppbtab(iii)) then 
     596 !                       idecal(iii) = idecal(iii)-1 
     597 !                       if (tempP(idecal(1),idecal(2),idecal(3),idecal(4)) == Agrif_SpecialValue) then 
     598 !                           imin(iii) = imax(iii) 
     599 !                       endif 
     600 !                       idecal(iii) = idecal(iii)+1 
     601 !                   endif 
     602 !               endif 
    548603            endif 
    549604        enddo 
     
    567622! 
    568623        if (Nbvals > 0) then 
    569             if (firsttest) then 
    570                 firsttest = .FALSE. 
    571                 i=1 
    572                 cycle 
    573             endif 
     624!            if (firsttest) then 
     625!                firsttest = .FALSE. 
     626!                i=1 
     627!                cycle 
     628!            endif 
    574629 
    575630            tempP(indic(1),indic(2),indic(3),indic(4)) = Res/Nbvals 
     631            ilook = i 
    576632            exit 
    577633        else 
    578             if (firsttest) exit 
     634!            if (firsttest) exit 
    579635            i = i + 1 
    580636        endif 
  • vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modmpp.F90

    r5656 r10087  
    166166subroutine Get_External_Data_first ( pttruetab, cetruetab, pttruetabwhole, cetruetabwhole,  & 
    167167                                     nbdim, memberoutall, coords, sendtoproc, recvfromproc, & 
    168                                      imin, imax, imin_recv, imax_recv ) 
     168                                     imin, imax, imin_recv, imax_recv, bornesmin, bornesmax ) 
    169169!--------------------------------------------------------------------------------------------------- 
    170170    include 'mpif.h' 
     
    179179    integer, dimension(nbdim,0:Agrif_NbProcs-1), intent(out) :: imin,imax 
    180180    integer, dimension(nbdim,0:Agrif_NbProcs-1), intent(out) :: imin_recv,imax_recv 
     181    integer, dimension(nbdim,0:Agrif_NbProcs-1), intent(in) :: bornesmin, bornesmax 
    181182! 
    182183    integer :: imintmp, imaxtmp, i, j, k, i1 
     
    211212            IF (cetruetab(i,Agrif_Procrank) > cetruetab(i,k)) THEN 
    212213                DO j=imin1,imax1 
    213                     IF ((cetruetab(i,k)-j) > (j-pttruetab(i,Agrif_Procrank))) THEN 
     214                    IF ((bornesmax(i,k)-j) > (j-bornesmin(i,Agrif_Procrank))) THEN 
    214215                        imintmp = j+1 
    215216                        tochange = .TRUE. 
     
    228229            IF (pttruetab(i,Agrif_Procrank) < pttruetab(i,k)) THEN 
    229230                DO j=imax1,imin1,-1 
    230                     IF ((j-pttruetab(i,k)) > (cetruetab(i,Agrif_Procrank)-j)) THEN 
     231                    IF ((j-bornesmin(i,k)) > (bornesmax(i,Agrif_Procrank)-j)) THEN 
    231232                        imaxtmp = j-1 
    232233                        tochange = .TRUE. 
     
    248249        sendtoproc(k) = .true. 
    249250! 
     251        IF ( .not. memberoutall(k) ) THEN 
     252            sendtoproc(k) = .false. 
     253        ELSE 
    250254!CDIR SHORTLOOP 
    251255        do i = 1,nbdim 
     
    257261            endif 
    258262        enddo 
    259         IF ( .not. memberoutall(k) ) THEN 
    260             sendtoproc(k) = .false. 
    261263        ENDIF 
    262264    enddo 
  • vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modsauv.F90

    r5656 r10087  
    2727! 
    2828module Agrif_Save 
    29 ! 
     29!    
    3030    use Agrif_Types 
    3131    use Agrif_Link 
    3232    use Agrif_Arrays 
    33     use Agrif_Variables 
     33    use Agrif_User_Variables 
    3434! 
    3535    implicit none 
     
    250250! 
    251251    type(Agrif_PGrid), pointer  :: parcours ! Pointer for the recursive procedure 
    252     real    :: g_eps, eps, oldgrid_eps 
     252    real(kind=8)    :: g_eps, eps, oldgrid_eps 
    253253    integer :: out 
    254254    integer :: iii 
     
    331331! 
    332332    type(Agrif_PGrid), pointer  :: parcours ! Pointer for the recursive procedure 
    333     real    :: g_eps,eps,oldgrid_eps 
     333    real(kind=8)    :: g_eps,eps,oldgrid_eps 
    334334    integer :: out 
    335335    integer :: iii 
     
    415415    integer, dimension(6) :: nbtabold  ! Number of cells in each direction 
    416416    integer, dimension(6) :: nbtabnew  ! Number of cells in each direction 
    417     real,    dimension(6) :: snew,sold 
    418     real,    dimension(6) :: dsnew,dsold 
    419     real    :: eps 
     417    real(kind=8),    dimension(6) :: snew,sold 
     418    real(kind=8),    dimension(6) :: dsnew,dsold 
     419    real(kind=8)    :: eps 
    420420    integer :: n 
    421421! 
     
    531531    integer, dimension(nbdim),     intent(in)    :: pttabold 
    532532    integer, dimension(nbdim),     intent(in)    :: petabold 
    533     real,    dimension(nbdim),     intent(in)    :: snew, sold 
    534     real,    dimension(nbdim),     intent(in)    :: dsnew,dsold 
     533    real(kind=8),    dimension(nbdim),     intent(in)    :: snew, sold 
     534    real(kind=8),    dimension(nbdim),     intent(in)    :: dsnew,dsold 
    535535    integer,                       intent(in)    :: nbdim 
    536536! 
    537537    integer :: i,j,k,l,m,n,i0,j0,k0,l0,m0,n0 
    538538! 
    539     real,    dimension(nbdim) :: dim_gmin,   dim_gmax 
    540     real,    dimension(nbdim) :: dim_newmin, dim_newmax 
    541     real,    dimension(nbdim) :: dim_min 
     539    real(kind=8),    dimension(nbdim) :: dim_gmin,   dim_gmax 
     540    real(kind=8),    dimension(nbdim) :: dim_newmin, dim_newmax 
     541    real(kind=8),    dimension(nbdim) :: dim_min 
    542542    integer, dimension(nbdim) :: ind_gmin,ind_newmin, ind_newmax 
    543543! 
  • vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modseq.F90

    r5656 r10087  
    33    use Agrif_Init 
    44    use Agrif_Procs 
    5     use Agrif_Arrays 
     5    use Agrif_Grids 
     6    !use Agrif_Arrays 
    67! 
    78    implicit none 
  • vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modtypes.F90

    r5656 r10087  
    109109    real(4), dimension(:,:,:,:,:,:), allocatable :: sarray6 
    110110!> @} 
     111!> \name Arrays containing the values of the grid variables (real) 
     112!> @{ 
     113    real,    dimension(:)          , pointer :: parray1 
     114    real,    dimension(:,:)        , pointer :: parray2 
     115    real,    dimension(:,:,:)      , pointer :: parray3 
     116    real,    dimension(:,:,:,:)    , pointer :: parray4 
     117    real,    dimension(:,:,:,:,:)  , pointer :: parray5 
     118    real,    dimension(:,:,:,:,:,:), pointer :: parray6 
     119!> @} 
     120!> \name Arrays containing the values of the grid variables (real*8) 
     121!> @{ 
     122    real(8), dimension(:)          , pointer :: pdarray1 
     123    real(8), dimension(:,:)        , pointer :: pdarray2 
     124    real(8), dimension(:,:,:)      , pointer :: pdarray3 
     125    real(8), dimension(:,:,:,:)    , pointer :: pdarray4 
     126    real(8), dimension(:,:,:,:,:)  , pointer :: pdarray5 
     127    real(8), dimension(:,:,:,:,:,:), pointer :: pdarray6 
     128!> @} 
     129!> \name Arrays containing the values of the grid variables (real*4) 
     130!> @{ 
     131    real(4), dimension(:)          , pointer :: psarray1 
     132    real(4), dimension(:,:)        , pointer :: psarray2 
     133    real(4), dimension(:,:,:)      , pointer :: psarray3 
     134    real(4), dimension(:,:,:,:)    , pointer :: psarray4 
     135    real(4), dimension(:,:,:,:,:)  , pointer :: psarray5 
     136    real(4), dimension(:,:,:,:,:,:), pointer :: psarray6 
     137!> @} 
    111138!> \name Arrays used to restore the values 
    112139!> @{ 
     
    132159    integer, dimension(6)   :: ub 
    133160 
     161    integer, dimension(6,2) :: lubglob 
     162 
    134163    logical,dimension(6,2) :: memberin 
    135164    integer,dimension(6,2,2,6,2) :: childarray 
     
    153182!> \name Arrays containing the values of the grid variables (character) 
    154183!> @{ 
    155     character(2400)                             :: carray0 
    156     character(200), dimension(:)  , allocatable :: carray1 
    157     character(200), dimension(:,:), allocatable :: carray2 
     184    character(4000)                             :: carray0 
     185    character(400), dimension(:)  , allocatable :: carray1 
     186    character(400), dimension(:,:), allocatable :: carray2 
    158187!> @} 
    159188!--------------------------------------------------------------------------------------------------- 
     
    218247!> \name Arrays containing the values of the grid variables (logical) 
    219248!> @{ 
    220     logical                                      :: larray0 
     249    logical                                      :: larray0 = .FALSE. 
    221250    logical, dimension(:)          , allocatable :: larray1 
    222251    logical, dimension(:,:)        , allocatable :: larray2 
     
    242271!> \name Arrays containing the values of the grid variables (integer) 
    243272!> @{ 
    244     integer                                      :: iarray0 
     273    integer                                      :: iarray0 = 0 
    245274    integer, dimension(:)          , allocatable :: iarray1 
    246275    integer, dimension(:,:)        , allocatable :: iarray2 
     
    259288    integer,dimension(6)              :: pttab, petab, pttab_Child, pttab_Parent = -99 
    260289    integer,dimension(6)              :: indmin, indmax 
     290    integer,dimension(6)              :: indmin_required_p, indmax_required_p 
    261291    integer,dimension(6)              :: pttruetab,cetruetab 
    262292    logical :: member, memberin 
     
    324354    real                  :: Agrif_Efficiency = 0.7 
    325355    integer               :: MaxSearch = 5 
    326     real, dimension(3)    :: Agrif_mind 
     356    real(kind=8), dimension(3)    :: Agrif_mind 
    327357!> @} 
    328358!> \name parameters for the interpolation of the child grids 
     
    388418integer function Agrif_Ceiling ( x ) 
    389419!--------------------------------------------------------------------------------------------------- 
    390     real,   intent(in) :: x 
     420    real(kind=8),intent(in) :: x 
    391421! 
    392422    integer   :: i 
     
    408438    integer function Agrif_Int(x) 
    409439!--------------------------------------------------------------------------------------------------- 
    410     real,   intent(in) :: x 
     440    real(kind=8),intent(in) :: x 
    411441! 
    412442    integer :: i 
  • vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modupdate.F90

    r5656 r10087  
    2727module Agrif_Update 
    2828! 
     29!    use Agrif_UpdateBasic 
     30!    use Agrif_Arrays 
     31!    use Agrif_CurgridFunctions 
     32!    use Agrif_Mask 
     33#if defined AGRIF_MPI 
     34!    use Agrif_Mpp 
     35#endif 
     36! 
    2937    use Agrif_UpdateBasic 
    3038    use Agrif_Arrays 
    31     use Agrif_CurgridFunctions 
     39    use Agrif_User_Functions 
     40    use Agrif_Init 
    3241    use Agrif_Mask 
     42     
    3343#if defined AGRIF_MPI 
    3444    use Agrif_Mpp 
     
    5868    integer, dimension(6) :: ub_child 
    5969    integer, dimension(6) :: lb_parent 
    60     real   , dimension(6) ::  s_child           ! Child  grid position (s_root = 0) 
    61     real   , dimension(6) ::  s_parent          ! Parent grid position (s_root = 0) 
    62     real   , dimension(6) :: ds_child           ! Child  grid dx (ds_root = 1) 
    63     real   , dimension(6) :: ds_parent          ! Parent grid dx (ds_root = 1) 
     70    real(kind=8)   , dimension(6) ::  s_child           ! Child  grid position (s_root = 0) 
     71    real(kind=8)   , dimension(6) ::  s_parent          ! Parent grid position (s_root = 0) 
     72    real(kind=8)   , dimension(6) :: ds_child           ! Child  grid dx (ds_root = 1) 
     73    real(kind=8)   , dimension(6) :: ds_parent          ! Parent grid dx (ds_root = 1) 
    6474    logical, dimension(6) :: do_update          ! Indicates if we perform update for each dimension 
    6575    integer, dimension(6) :: posvar             ! Position of the variable on the cell (1 or 2) 
     
    160170    integer, dimension(nbdim), intent(in) :: posvar         !< Position of the variable on the cell (1 or 2) 
    161171    logical, dimension(nbdim), intent(in) :: do_update      !< Indicates if we update for each dimension 
    162     real,    dimension(nbdim), intent(in) :: s_child        !< Positions of the child grid 
    163     real,    dimension(nbdim), intent(in) :: s_parent       !< Positions of the parent grid 
    164     real,    dimension(nbdim), intent(in) :: ds_child       !< Space steps of the child grid 
    165     real,    dimension(nbdim), intent(in) :: ds_parent      !< Space steps of the parent grid 
     172    real(kind=8),    dimension(nbdim), intent(in) :: s_child        !< Positions of the child grid 
     173    real(kind=8),    dimension(nbdim), intent(in) :: s_parent       !< Positions of the parent grid 
     174    real(kind=8),    dimension(nbdim), intent(in) :: ds_child       !< Space steps of the child grid 
     175    real(kind=8),    dimension(nbdim), intent(in) :: ds_parent      !< Space steps of the parent grid 
    166176    procedure()                           :: procname       !< Data recovery procedure 
    167177! 
     
    230240! lubglob(:,2) : global lbound for each dimension 
    231241! 
    232     call Agrif_get_var_global_bounds(child, lubglob, nbdim) 
     242!     call Agrif_get_var_global_bounds(child, lubglob, nbdim) 
     243    lubglob = child % lubglob(1:nbdim,:) 
    233244! 
    234245    indtruetab(1:nbdim,1,1) = max(indtab(1:nbdim,1,1), lubglob(1:nbdim,1)) 
     
    274285    integer, dimension(nbdim), intent(in)   :: posvar       !< Position of the variable on the cell (1 or 2) 
    275286    logical, dimension(nbdim), intent(in)   :: do_update    !< Indicates if we update for each dimension 
    276     real,    dimension(nbdim), intent(in)   :: s_child      !< Positions of the child grid 
    277     real,    dimension(nbdim), intent(in)   :: s_parent     !< Positions of the parent grid 
    278     real,    dimension(nbdim), intent(in)   :: ds_child     !< Space steps of the child grid 
    279     real,    dimension(nbdim), intent(in)   :: ds_parent    !< Space steps of the parent grid 
     287    real(kind=8),    dimension(nbdim), intent(in)   :: s_child      !< Positions of the child grid 
     288    real(kind=8),    dimension(nbdim), intent(in)   :: s_parent     !< Positions of the parent grid 
     289    real(kind=8),    dimension(nbdim), intent(in)   :: ds_child     !< Space steps of the child grid 
     290    real(kind=8),    dimension(nbdim), intent(in)   :: ds_parent    !< Space steps of the parent grid 
    280291    procedure()                             :: procname     !< Data recovery procedure 
    281292! 
     
    390401#endif 
    391402! 
    392     integer, dimension(6),     intent(in)   :: type_update  !< Type of update (copy or average) 
    393403    type(Agrif_Variable), pointer           :: parent       !< Variable of the parent grid 
    394404    type(Agrif_Variable), pointer           :: child        !< Variable of the child grid 
    395405    integer,                   intent(in)   :: nbdim 
     406    integer, dimension(nbdim), intent(in)   :: type_update  !< Type of update (copy or average) 
    396407    integer, dimension(nbdim), intent(in)   :: pttab        !< Index of the first point inside the domain 
    397408    integer, dimension(nbdim), intent(in)   :: petab        !< Index of the first point inside the domain 
     
    400411    integer, dimension(nbdim), intent(in)   :: lb_parent !< Index of the first point inside the domain for the parent 
    401412                                                            !!    grid variable 
    402     real,    dimension(nbdim), intent(in)   :: s_child      !< Positions of the child grid 
    403     real,    dimension(nbdim), intent(in)   :: s_parent     !< Positions of the parent grid 
    404     real,    dimension(nbdim), intent(in)   :: ds_child     !< Space steps of the child grid 
    405     real,    dimension(nbdim), intent(in)   :: ds_parent    !< Space steps of the parent grid 
     413    real(kind=8),    dimension(nbdim), intent(in)   :: s_child      !< Positions of the child grid 
     414    real(kind=8),    dimension(nbdim), intent(in)   :: s_parent     !< Positions of the parent grid 
     415    real(kind=8),    dimension(nbdim), intent(in)   :: ds_child     !< Space steps of the child grid 
     416    real(kind=8),    dimension(nbdim), intent(in)   :: ds_parent    !< Space steps of the parent grid 
    406417    procedure()                             :: procname     !< Data recovery procedure 
    407418    integer, optional,         intent(in)   :: nb, ndir 
     
    415426    integer, dimension(nbdim)       :: indmin, indmax 
    416427    integer, dimension(nbdim)       :: indminglob, indmaxglob 
    417     real   , dimension(nbdim)       :: s_Child_temp, s_Parent_temp 
     428    real(kind=8)   , dimension(nbdim)       :: s_Child_temp, s_Parent_temp 
    418429    integer, dimension(nbdim)       :: lowerbound,upperbound 
    419430    integer, dimension(nbdim)       :: pttruetabwhole, cetruetabwhole 
     
    450461    real :: coeff_multi 
    451462    integer :: nb_dimensions 
     463 
    452464! 
    453465!   Get local lower and upper bound of the child variable 
     
    506518! 
    507519        call Agrif_array_allocate(tempC,pttruetab,cetruetab,nbdim) 
     520#if defined AGRIF_MPI 
    508521        call Agrif_var_set_array_tozero(tempC,nbdim) 
     522#endif 
    509523 
    510524        SELECT CASE (nbdim) 
     
    582596                                     nbdim, memberinall, coords,                            & 
    583597                                     sendtoproc1,recvfromproc1,                             & 
    584                                      tab4t(:,:,5),tab4t(:,:,6),tab4t(:,:,7),tab4t(:,:,8)) 
     598                                     tab4t(:,:,5),tab4t(:,:,6),tab4t(:,:,7),tab4t(:,:,8),   & 
     599                                     tab4t(:,:,1),tab4t(:,:,2)) 
    585600    endif 
    586601 
     
    600615! 
    601616        call Agrif_array_allocate(tempP,indmin,indmax,nbdim) 
    602 ! 
     617 
     618        IF (Agrif_UseSpecialValueInUpdate) THEN 
     619            allocate(tempC_indic) 
     620            allocate(tempP_indic) 
     621            call Agrif_array_allocate(tempC_indic,pttruetabwhole,cetruetabwhole,nbdim) 
     622            call Agrif_array_allocate(tempP_indic,indmin,indmax,nbdim) 
     623            call agrif_set_array_cond(tempCextend,tempC_indic,agrif_SpecialValueFineGrid,nbdim) 
     624        ELSE 
     625            tempC_indic=>tempCextend ! Just to associate tempC_indic to something ... 
     626        ENDIF 
     627! 
     628 
     629 
    603630        if ( nbdim == 1 ) then 
    604631            tempP % array1 = 0. 
     
    606633                                            tempP%array1,   & 
    607634                                            tempCextend%array1, & 
     635                                            tempC_indic%array1, & 
    608636                                            indmin(1), indmax(1),   & 
    609637                                            pttruetabwhole(1), cetruetabwhole(1),   & 
     
    612640                                             
    613641            IF (Agrif_UseSpecialValueInUpdate) THEN 
    614             allocate(tempC_indic) 
    615             allocate(tempP_indic) 
    616             call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array1),ubound(tempCextend%array1),nbdim) 
    617             call Agrif_array_allocate(tempP_indic,lbound(tempP%array1),ubound(tempP%array1),nbdim) 
    618642 
    619643            compute_average = .FALSE. 
     
    629653                                            tempP_average%array1,       & 
    630654                                            tempCextend%array1, & 
     655                                            tempC_indic%array1, & 
    631656                                            indmin(1), indmax(1),   & 
    632657                                            pttruetabwhole(1), cetruetabwhole(1),   & 
     
    639664            ENDIF 
    640665             
    641             WHERE (tempCextend%array1 == Agrif_SpecialValueFineGrid) 
    642               tempC_indic%array1 = 0. 
    643             ELSEWHERE 
    644               tempC_indic%array1 = 1. 
    645             END WHERE 
    646              
    647666            Agrif_UseSpecialValueInUpdate = .FALSE. 
    648667            Agrif_Update_Weights = .TRUE. 
     
    650669             call Agrif_Update_1D_Recursive( type_update_temp(1),   & 
    651670                                            tempP_indic%array1,       & 
     671                                            tempC_indic%array1, & 
    652672                                            tempC_indic%array1, & 
    653673                                            indmin(1), indmax(1),   & 
     
    691711                                            tempP%array2,       & 
    692712                                            tempCextend%array2, & 
     713                                            tempC_indic%array2, & 
    693714                                            indmin(1:2), indmax(1:2),   & 
    694715                                            pttruetabwhole(1:2), cetruetabwhole(1:2),   & 
     
    697718 
    698719            IF (Agrif_UseSpecialValueInUpdate) THEN 
    699             allocate(tempC_indic) 
    700             allocate(tempP_indic) 
    701             call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array2),ubound(tempCextend%array2),nbdim) 
    702             call Agrif_array_allocate(tempP_indic,lbound(tempP%array2),ubound(tempP%array2),nbdim) 
    703720  
    704721            compute_average = .FALSE. 
     
    714731                                            tempP_average%array2,       & 
    715732                                            tempCextend%array2, & 
     733                                            tempC_indic%array2, & 
    716734                                            indmin(1:2), indmax(1:2),   & 
    717735                                            pttruetabwhole(1:2), cetruetabwhole(1:2),   & 
     
    724742            ENDIF 
    725743             
    726             WHERE (tempCextend%array2 == Agrif_SpecialValueFineGrid) 
    727               tempC_indic%array2 = 0. 
    728             ELSEWHERE 
    729               tempC_indic%array2 = 1. 
    730             END WHERE 
    731              
    732744            Agrif_UseSpecialValueInUpdate = .FALSE. 
    733745            Agrif_Update_Weights = .TRUE. 
     
    735747            call Agrif_Update_2D_Recursive( type_update_temp(1:2),   & 
    736748                                            tempP_indic%array2,       & 
     749                                            tempC_indic%array2, & 
    737750                                            tempC_indic%array2, & 
    738751                                            indmin(1:2), indmax(1:2),   & 
     
    773786        endif 
    774787        if ( nbdim == 3 ) then 
     788 
    775789            call Agrif_Update_3D_Recursive( type_update(1:3),   & 
    776790                                            tempP%array3,       & 
    777791                                            tempCextend%array3, & 
     792                                            tempC_indic%array3, & 
    778793                                            indmin(1:3), indmax(1:3),   & 
    779794                                            pttruetabwhole(1:3), cetruetabwhole(1:3),   & 
    780795                                            s_Child_temp(1:3), s_Parent_temp(1:3),      & 
    781796                                            ds_child(1:3), ds_parent(1:3) ) 
    782                                              
     797 
     798                       
    783799            IF (Agrif_UseSpecialValueInUpdate) THEN 
    784             allocate(tempC_indic) 
    785             allocate(tempP_indic) 
    786             call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array3),ubound(tempCextend%array3),nbdim) 
    787             call Agrif_array_allocate(tempP_indic,lbound(tempP%array3),ubound(tempP%array3),nbdim) 
    788800 
    789801            compute_average = .FALSE. 
     
    796808                type_update_temp(1:nbdim) = Agrif_Update_Average 
    797809              END WHERE 
     810 
    798811              call Agrif_Update_3D_Recursive( type_update_temp(1:3),   & 
    799812                                            tempP_average%array3,       & 
    800813                                            tempCextend%array3, & 
     814                                            tempC_indic%array3, & 
    801815                                            indmin(1:3), indmax(1:3),   & 
    802816                                            pttruetabwhole(1:3), cetruetabwhole(1:3),   & 
     
    808822              enddo 
    809823            ENDIF 
    810              
    811             WHERE (tempCextend%array3 == Agrif_SpecialValueFineGrid) 
    812               tempC_indic%array3 = 0. 
    813             ELSEWHERE 
    814               tempC_indic%array3 = 1. 
    815             END WHERE 
    816              
     824 
    817825            Agrif_UseSpecialValueInUpdate = .FALSE. 
    818826            Agrif_Update_Weights = .TRUE. 
    819   
     827 
     828 
    820829             call Agrif_Update_3D_Recursive( type_update_temp(1:3),   & 
    821830                                            tempP_indic%array3,       & 
    822831                                            tempC_indic%array3, & 
     832                                            tempCextend%array3, & 
    823833                                            indmin(1:3), indmax(1:3),   & 
    824834                                            pttruetabwhole(1:3), cetruetabwhole(1:3),   & 
     
    826836                                            ds_child(1:3), ds_parent(1:3) ) 
    827837 
     838 
    828839           Agrif_UseSpecialValueInUpdate = .TRUE. 
    829840           Agrif_Update_Weights = .FALSE. 
    830841 
     842 
    831843           IF (compute_average) THEN 
     844          
    832845               WHERE (tempP_indic%array3 == 0.) 
    833846                  tempP%array3 = Agrif_SpecialValueFineGrid 
     
    837850                  tempP%array3 = tempP_average%array3 /tempP_indic%array3 
    838851               END WHERE 
    839  
     852             
    840853           ELSE 
    841854               WHERE (tempP_indic%array3 == 0.) 
     
    845858               END WHERE 
    846859            ENDIF 
    847             
     860 
    848861            deallocate(tempP_indic%array3) 
    849862            deallocate(tempC_indic%array3) 
     
    855868            ENDIF 
    856869            ENDIF 
    857              
     870 
     871          
    858872        endif 
    859873        if ( nbdim == 4 ) then 
     874           
    860875            call Agrif_Update_4D_Recursive( type_update(1:4),   & 
    861876                                            tempP%array4,       & 
    862877                                            tempCextend%array4, & 
     878                                            tempC_indic%array4, & 
    863879                                            indmin(1:4), indmax(1:4),   & 
    864880                                            pttruetabwhole(1:4), cetruetabwhole(1:4),   & 
    865881                                            s_Child_temp(1:4), s_Parent_temp(1:4),      & 
    866882                                            ds_child(1:4), ds_parent(1:4) ) 
    867                                              
     883                 
    868884            IF (Agrif_UseSpecialValueInUpdate) THEN 
    869              
    870             allocate(tempC_indic) 
    871             allocate(tempP_indic) 
    872             call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array4),ubound(tempCextend%array4),nbdim) 
    873             call Agrif_array_allocate(tempP_indic,lbound(tempP%array4),ubound(tempP%array4),nbdim) 
    874885            
    875886            compute_average = .FALSE. 
     
    885896                                            tempP_average%array4,       & 
    886897                                            tempCextend%array4, & 
     898                                            tempC_indic%array4, & 
    887899                                            indmin(1:4), indmax(1:4),   & 
    888900                                            pttruetabwhole(1:4), cetruetabwhole(1:4),   & 
     
    895907            ENDIF 
    896908             
    897             WHERE (tempCextend%array4 == Agrif_SpecialValueFineGrid) 
    898               tempC_indic%array4 = 0. 
    899             ELSEWHERE 
    900               tempC_indic%array4 = 1. 
    901             END WHERE 
    902              
    903909            Agrif_UseSpecialValueInUpdate = .FALSE. 
    904910            Agrif_Update_Weights = .TRUE. 
     
    906912             call Agrif_Update_4D_Recursive( type_update_temp(1:4),   & 
    907913                                            tempP_indic%array4,       & 
     914                                            tempC_indic%array4, & 
    908915                                            tempC_indic%array4, & 
    909916                                            indmin(1:4), indmax(1:4),   & 
     
    940947            ENDIF 
    941948            ENDIF 
    942              
     949                  
    943950        endif 
    944951        if ( nbdim == 5 ) then 
     
    946953                                            tempP%array5,       & 
    947954                                            tempCextend%array5, & 
     955                                            tempC_indic%array5, & 
    948956                                            indmin(1:5), indmax(1:5),   & 
    949957                                            pttruetabwhole(1:5), cetruetabwhole(1:5),   & 
     
    952960                                             
    953961            IF (Agrif_UseSpecialValueInUpdate) THEN 
    954             allocate(tempC_indic) 
    955             allocate(tempP_indic) 
    956             call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array5),ubound(tempCextend%array5),nbdim) 
    957             call Agrif_array_allocate(tempP_indic,lbound(tempP%array5),ubound(tempP%array5),nbdim) 
    958962 
    959963            compute_average = .FALSE. 
     
    969973                                            tempP_average%array5,       & 
    970974                                            tempCextend%array5, & 
     975                                            tempC_indic%array5, & 
    971976                                            indmin(1:5), indmax(1:5),   & 
    972977                                            pttruetabwhole(1:5), cetruetabwhole(1:5),   & 
     
    979984            ENDIF 
    980985             
    981             WHERE (tempCextend%array5 == Agrif_SpecialValueFineGrid) 
    982               tempC_indic%array5 = 0. 
    983             ELSEWHERE 
    984               tempC_indic%array5 = 1. 
    985             END WHERE 
    986              
    987986            Agrif_UseSpecialValueInUpdate = .FALSE. 
    988987            Agrif_Update_Weights = .TRUE. 
     
    990989             call Agrif_Update_5D_Recursive( type_update_temp(1:5),   & 
    991990                                            tempP_indic%array5,       & 
     991                                            tempC_indic%array5, & 
    992992                                            tempC_indic%array5, & 
    993993                                            indmin(1:5), indmax(1:5),   & 
     
    10311031                                            tempP%array6,       & 
    10321032                                            tempCextend%array6, & 
     1033                                            tempC_indic%array6, & 
    10331034                                            indmin(1:6), indmax(1:6),   & 
    10341035                                            pttruetabwhole(1:6), cetruetabwhole(1:6),   & 
    10351036                                            s_Child_temp(1:6), s_Parent_temp(1:6),      & 
    10361037                                            ds_child(1:6), ds_parent(1:6) ) 
     1038 
    10371039            IF (Agrif_UseSpecialValueInUpdate) THEN 
    1038             allocate(tempC_indic) 
    1039             allocate(tempP_indic) 
    1040             call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array6),ubound(tempCextend%array6),nbdim) 
    1041             call Agrif_array_allocate(tempP_indic,lbound(tempP%array6),ubound(tempP%array6),nbdim) 
    10421040 
    10431041            compute_average = .FALSE. 
     
    10541052                                            tempP_average%array6,       & 
    10551053                                            tempCextend%array6, & 
     1054                                            tempC_indic%array6, & 
    10561055                                            indmin(1:6), indmax(1:6),   & 
    10571056                                            pttruetabwhole(1:6), cetruetabwhole(1:6),   & 
     
    10641063            ENDIF 
    10651064 
     1065             
     1066            Agrif_UseSpecialValueInUpdate = .FALSE. 
     1067            Agrif_Update_Weights = .TRUE. 
     1068  
     1069             call Agrif_Update_6D_Recursive( type_update_temp(1:6),   & 
     1070                                            tempP_indic%array6,       & 
     1071                                            tempC_indic%array6, & 
     1072                                            tempC_indic%array6, & 
     1073                                            indmin(1:6), indmax(1:6),   & 
     1074                                            pttruetabwhole(1:6), cetruetabwhole(1:6),   & 
     1075                                            s_Child_temp(1:6), s_Parent_temp(1:6),      & 
     1076                                            ds_child(1:6), ds_parent(1:6) ) 
     1077 
     1078           Agrif_UseSpecialValueInUpdate = .TRUE. 
     1079           Agrif_Update_Weights = .FALSE. 
     1080            
    10661081           IF (compute_average) THEN 
    10671082               WHERE (tempP_indic%array6 == 0.) 
     
    10801095               END WHERE 
    10811096            ENDIF 
    1082              
    1083             Agrif_UseSpecialValueInUpdate = .FALSE. 
    1084             Agrif_Update_Weights = .TRUE. 
    1085   
    1086              call Agrif_Update_6D_Recursive( type_update_temp(1:6),   & 
    1087                                             tempP_indic%array6,       & 
    1088                                             tempC_indic%array6, & 
    1089                                             indmin(1:6), indmax(1:6),   & 
    1090                                             pttruetabwhole(1:6), cetruetabwhole(1:6),   & 
    1091                                             s_Child_temp(1:6), s_Parent_temp(1:6),      & 
    1092                                             ds_child(1:6), ds_parent(1:6) ) 
    1093  
    1094            Agrif_UseSpecialValueInUpdate = .TRUE. 
    1095            Agrif_Update_Weights = .FALSE. 
    1096             
    1097             WHERE (tempP_indic%array6 == 0.) 
    1098               tempP%array6 = Agrif_SpecialValueFineGrid 
    1099             ELSEWHERE 
    1100               tempP%array6 = tempP%array6 /tempP_indic%array6 
    1101             END WHERE 
    11021097            
    11031098            deallocate(tempP_indic%array6) 
     
    11541149                                     nbdim, memberinall2, coords,                           & 
    11551150                                     sendtoproc2, recvfromproc2,                            & 
    1156                                      tab5t(:,:,5),tab5t(:,:,6),tab5t(:,:,7),tab5t(:,:,8)) 
     1151                                     tab5t(:,:,5),tab5t(:,:,6),tab5t(:,:,7),tab5t(:,:,8),   & 
     1152                                     tab5t(:,:,1),tab5t(:,:,2)) 
    11571153 
    11581154        call Agrif_Addto_list_update(child%list_update,pttab,petab,lb_child,lb_parent,      & 
     
    13231319    integer,                   intent(in)   :: nbdim 
    13241320    integer, dimension(nbdim), intent(out)  :: indmin, indmax 
    1325     real,    dimension(nbdim), intent(out)  :: s_Parent_temp, s_Child_temp 
    1326     real,    dimension(nbdim), intent(in)   :: s_child,  ds_child 
    1327     real,    dimension(nbdim), intent(in)   :: s_parent, ds_parent 
     1321    real(kind=8),    dimension(nbdim), intent(out)  :: s_Parent_temp, s_Child_temp 
     1322    real(kind=8),    dimension(nbdim), intent(in)   :: s_child,  ds_child 
     1323    real(kind=8),    dimension(nbdim), intent(in)   :: s_parent, ds_parent 
    13281324    integer, dimension(nbdim), intent(in)   :: pttruetab, cetruetab 
    13291325    integer, dimension(nbdim), intent(in)   :: lb_child, lb_parent 
     
    13351331#endif 
    13361332! 
    1337     real,dimension(nbdim) :: dim_newmin,dim_newmax 
     1333    real(kind=8),dimension(nbdim) :: dim_newmin,dim_newmax 
    13381334    integer :: i 
    13391335#if defined AGRIF_MPI 
    1340     real    :: positionmin, positionmax 
     1336    real(kind=8)    :: positionmin, positionmax 
    13411337    integer :: imin, imax 
    13421338    integer :: coeffraf 
     
    14221418!> Updates a 1D grid variable on the parent grid 
    14231419!--------------------------------------------------------------------------------------------------- 
    1424 subroutine Agrif_Update_1D_Recursive ( type_update,         & 
    1425                                        tempP, tempC,        & 
    1426                                        indmin, indmax,      & 
    1427                                        lb_child, ub_child,  & 
    1428                                        s_child,  s_parent,  & 
     1420subroutine Agrif_Update_1D_Recursive ( type_update,                     & 
     1421                                       tempP, tempC, tempC_indic,       & 
     1422                                       indmin, indmax,                  & 
     1423                                       lb_child, ub_child,              & 
     1424                                       s_child,  s_parent,              & 
    14291425                                       ds_child, ds_parent ) 
    14301426!--------------------------------------------------------------------------------------------------- 
     
    14321428    integer,                            intent(in)  :: indmin, indmax 
    14331429    integer,                            intent(in)  :: lb_child, ub_child 
    1434     real,                               intent(in)  ::  s_child,  s_parent 
    1435     real,                               intent(in)  :: ds_child, ds_parent 
     1430    real(kind=8),                               intent(in)  ::  s_child,  s_parent 
     1431    real(kind=8),                               intent(in)  :: ds_child, ds_parent 
    14361432    real, dimension(indmin:indmax),     intent(out) :: tempP 
    1437     real, dimension(lb_child:ub_child), intent(in)  :: tempC 
     1433    real, dimension(lb_child:ub_child), intent(in)  :: tempC, tempC_indic 
    14381434!--------------------------------------------------------------------------------------------------- 
    14391435    call Agrif_UpdateBase(type_update,              & 
     
    14541450!! Calls #Agrif_Update_1D_Recursive and #Agrif_UpdateBase 
    14551451!--------------------------------------------------------------------------------------------------- 
    1456 subroutine Agrif_Update_2D_Recursive ( type_update,         & 
    1457                                        tempP, tempC,        & 
    1458                                        indmin, indmax,      & 
    1459                                        lb_child, ub_child,  & 
    1460                                         s_child,  s_parent, & 
     1452subroutine Agrif_Update_2D_Recursive ( type_update,                     & 
     1453                                       tempP, tempC, tempC_indic,       & 
     1454                                       indmin, indmax,                  & 
     1455                                       lb_child, ub_child,              & 
     1456                                       s_child,  s_parent,              & 
    14611457                                       ds_child, ds_parent ) 
    14621458!--------------------------------------------------------------------------------------------------- 
     
    14641460    integer, dimension(2),          intent(in)  :: indmin, indmax 
    14651461    integer, dimension(2),          intent(in)  :: lb_child, ub_child 
    1466     real,    dimension(2),          intent(in)  ::  s_child,  s_parent 
    1467     real,    dimension(2),          intent(in)  :: ds_child, ds_parent 
     1462    real(kind=8),    dimension(2),          intent(in)  ::  s_child,  s_parent 
     1463    real(kind=8),    dimension(2),          intent(in)  :: ds_child, ds_parent 
    14681464    real,    dimension(          & 
    14691465        indmin(1):indmax(1),     & 
    14701466        indmin(2):indmax(2)),       intent(out) :: tempP 
    1471     real,    dimension(:,:),        intent(in)  :: tempC 
     1467    real,    dimension(:,:),        intent(in)  :: tempC, tempC_indic 
    14721468!--------------------------------------------------------------------------------------------------- 
    14731469    real, dimension(indmin(1):indmax(1), lb_child(2):ub_child(2)) :: tabtemp 
     
    14751471    real, dimension(lb_child(2):ub_child(2), indmin(1):indmax(1)) :: tabtemp_trsp 
    14761472    integer :: i, j 
    1477     integer :: coeffraf 
    1478 ! 
    1479     tabtemp = 0. 
     1473    integer :: coeffraf, coeffraf_2 
     1474   integer :: jmin,jmax 
     1475    integer locind_child_left, locind_child_left_2,kuinf 
     1476    logical :: to_transpose 
     1477    real :: invcoeffraf 
     1478    integer :: diffmod, jj,i1,j1 
     1479 
     1480 
     1481    to_transpose = .TRUE. 
     1482! 
     1483     
    14801484    coeffraf = nint ( ds_parent(1) / ds_child(1) ) 
    14811485! 
     
    14901494        endif 
    14911495!---CDIR NEXPAND 
     1496        tabtemp = 0. 
    14921497        call Average1dAfterCompute( tabtemp, tempC, size(tabtemp), size(tempC), & 
    14931498                    s_parent(1),s_child(1),ds_parent(1),ds_child(1),1) 
     
    15031508        endif 
    15041509!---CDIR NEXPAND 
     1510 
    15051511        call Agrif_basicupdate_copy1d_after(tabtemp,tempC,size(tabtemp),size(tempC),1) 
    15061512! 
     1513    ELSE IF ((coeffraf == 1).AND.(type_update(2) == Agrif_Update_Average)) THEN 
     1514            locind_child_left = 1+agrif_int((s_parent(1)-s_child(1))/ds_child(1)) 
     1515            coeffraf_2 = nint ( ds_parent(2) / ds_child(2) ) 
     1516            invcoeffraf = 1./coeffraf_2 
     1517            tempP = 0. 
     1518            diffmod = 0 
     1519            if (mod(coeffraf_2,2) == 0) diffmod = 1 
     1520            locind_child_left_2 = 1+agrif_int((s_parent(2)-s_child(2))/ds_child(2)) 
     1521 
     1522            if (Agrif_UseSpecialValueInUpdate) then 
     1523              j1 = -coeffraf_2/2+locind_child_left_2+diffmod 
     1524              do j=indmin(2),indmax(2) 
     1525                do jj=j1,j1+coeffraf_2-1 
     1526                  i1 = locind_child_left 
     1527                  do i=indmin(1),indmax(1) 
     1528                     tempP(i,j) = tempP(i,j) + tempC(i1,jj)*tempC_indic(i1,jj) 
     1529                     i1 = i1 + 1 
     1530                  enddo 
     1531                enddo 
     1532                j1 = j1 + coeffraf_2 
     1533              enddo 
     1534            else 
     1535              j1 = -coeffraf_2/2+locind_child_left_2+diffmod 
     1536              do j=indmin(2),indmax(2) 
     1537                do jj=j1,j1+coeffraf_2-1 
     1538                  do i=indmin(1),indmax(1) 
     1539                       tempP(i,j) = tempP(i,j) + tempC(locind_child_left+i-indmin(1),jj) 
     1540                  enddo 
     1541                enddo 
     1542                j1 = j1 + coeffraf_2 
     1543              enddo 
     1544              if (.not.Agrif_Update_Weights) tempP = tempP * invcoeffraf 
     1545            endif 
     1546            return 
     1547! 
     1548    ELSE IF ((coeffraf == 1).AND.(type_update(2) == Agrif_Update_Copy)) THEN 
     1549 
     1550            locind_child_left = 1 + agrif_int((s_parent(1)-s_child(1))/ds_child(1)) 
     1551! 
     1552            locind_child_left_2 = 1+nint((s_parent(2)-s_child(2))/ds_child(2)) 
     1553            coeffraf_2 = nint ( ds_parent(2) / ds_child(2) ) 
     1554 
     1555            do j=indmin(2),indmax(2) 
     1556              do i=indmin(1),indmax(1) 
     1557                tempP(i,j) = tempC(locind_child_left+i-indmin(1),locind_child_left_2) 
     1558              enddo 
     1559              locind_child_left_2 = locind_child_left_2 + coeffraf_2 
     1560            enddo 
     1561 
     1562            return 
     1563 
     1564    ELSE IF (coeffraf == 1) THEN 
     1565            locind_child_left = 1 + agrif_int((s_parent(1)-s_child(1))/ds_child(1)) 
     1566! 
     1567            do j = lb_child(2),ub_child(2) 
     1568!              tabtemp(indmin(1):indmax(1),j) = tempC(locind_child_left:locind_child_left+indmax(1)-indmin(1),j-lb_child(2)+1) 
     1569              tabtemp_trsp(j,indmin(1):indmax(1)) = tempC(locind_child_left:locind_child_left+indmax(1)-indmin(1),j-lb_child(2)+1) 
     1570            enddo 
     1571            to_transpose = .FALSE. 
    15071572    ELSE 
    15081573        do j = lb_child(2),ub_child(2) 
     
    15121577                                            tabtemp(:,j),               & 
    15131578                                            tempC(:,j-lb_child(2)+1),   & 
     1579                                            tempC_indic(:,j-lb_child(2)+1),   & 
    15141580                                            indmin(1), indmax(1),       & 
    15151581                                            lb_child(1),ub_child(1),    & 
     
    15191585    ENDIF 
    15201586! 
    1521     tabtemp_trsp = TRANSPOSE(tabtemp) 
     1587 
     1588    if (to_transpose) tabtemp_trsp = TRANSPOSE(tabtemp) 
     1589 
    15221590    coeffraf = nint(ds_parent(2)/ds_child(2)) 
    15231591! 
     
    15641632    ENDIF 
    15651633! 
     1634 
     1635    
    15661636    tempP = TRANSPOSE(tempP_trsp) 
    15671637!--------------------------------------------------------------------------------------------------- 
    15681638end subroutine Agrif_Update_2D_Recursive 
    1569 !=================================================================================================== 
    1570 ! 
    1571 subroutine Agrif_Update_2D_Recursive_ok ( type_update, & 
    1572                                         tempP, tempC, & 
    1573                                         indmin, indmax,   & 
    1574                                        lb_child, ub_child,                    & 
    1575                                        s_child, s_parent, ds_child, ds_parent ) 
    1576 !--------------------------------------------------------------------------------------------------- 
    1577     INTEGER, DIMENSION(2), intent(in)   :: type_update            !< Type of update (copy or average) 
    1578     INTEGER, DIMENSION(2), intent(in)   :: indmin, indmax 
    1579     INTEGER, DIMENSION(2), intent(in)   :: lb_child, ub_child 
    1580     REAL,    DIMENSION(2), intent(in)   :: s_child,  s_parent 
    1581     REAL,    DIMENSION(2), intent(in)   :: ds_child, ds_parent 
    1582     REAL,    DIMENSION(                 & 
    1583                 indmin(1):indmax(1),    & 
    1584                 indmin(2):indmax(2)),           intent(out) :: tempP 
    1585     REAL, DIMENSION(                            & 
    1586                 lb_child(1):ub_child(1),  & 
    1587                 lb_child(2):ub_child(2)), intent(in)  :: tempC 
    1588 ! 
    1589     REAL, DIMENSION(indmin(1):indmax(1), lb_child(2):ub_child(2)) :: tabtemp 
    1590     INTEGER :: i 
    1591 ! 
    1592     do i = lb_child(2),ub_child(2) 
    1593         call Agrif_Update_1D_Recursive(type_update(1),                              & 
    1594                                        tabtemp(:, i),          & 
    1595                                        tempC(:,i),  & 
    1596                                        indmin(1),indmax(1),                 & 
    1597                                        lb_child(1),ub_child(1),       & 
    1598                                        s_child(1), s_parent(1),             & 
    1599                                       ds_child(1),ds_parent(1)) 
    1600     enddo 
    1601 ! 
    1602     tempP = 0. 
    1603 ! 
    1604     do i = indmin(1),indmax(1) 
    1605         call Agrif_UpdateBase(type_update(2),                                       & 
    1606                               tempP(i,:),             & 
    1607                               tabtemp(i,:), & 
    1608                               indmin(2),indmax(2),                          & 
    1609                               lb_child(2),ub_child(2),                & 
    1610                               s_parent(2),s_child(2),                       & 
    1611                              ds_parent(2),ds_child(2)) 
    1612     enddo 
    1613 !--------------------------------------------------------------------------------------------------- 
    1614 end subroutine Agrif_Update_2D_Recursive_ok 
    16151639!=================================================================================================== 
    16161640 
     
    16221646!! Calls #Agrif_Update_2D_Recursive and #Agrif_UpdateBase. 
    16231647!--------------------------------------------------------------------------------------------------- 
    1624 subroutine Agrif_Update_3D_Recursive ( type_update,         & 
    1625                                        tempP, tempC,        & 
    1626                                        indmin, indmax,      & 
    1627                                        lb_child, ub_child,  & 
    1628                                         s_child,  s_parent, & 
     1648subroutine Agrif_Update_3D_Recursive ( type_update,                     & 
     1649                                       tempP, tempC, tempC_indic,       & 
     1650                                       indmin, indmax,                  & 
     1651                                       lb_child, ub_child,              & 
     1652                                       s_child,  s_parent,              & 
    16291653                                       ds_child, ds_parent ) 
    16301654!--------------------------------------------------------------------------------------------------- 
     
    16321656    integer, dimension(3),          intent(in)  :: indmin, indmax 
    16331657    integer, dimension(3),          intent(in)  :: lb_child, ub_child 
    1634     real,    dimension(3),          intent(in)  ::  s_child,  s_parent 
    1635     real,    dimension(3),          intent(in)  :: ds_child, ds_parent 
     1658    real(kind=8),    dimension(3),          intent(in)  ::  s_child,  s_parent 
     1659    real(kind=8),    dimension(3),          intent(in)  :: ds_child, ds_parent 
    16361660    real,    dimension(          & 
    16371661        indmin(1):indmax(1),     & 
     
    16411665        lb_child(1):ub_child(1), & 
    16421666        lb_child(2):ub_child(2), & 
    1643         lb_child(3):ub_child(3)),   intent(in)  :: tempC 
     1667        lb_child(3):ub_child(3)),   intent(in)  :: tempC, tempC_indic 
    16441668!--------------------------------------------------------------------------------------------------- 
    16451669    real, dimension(            & 
     
    16501674    integer :: coeffraf,locind_child_left 
    16511675    integer :: kuinf 
     1676    REAL :: invcoeffraf 
     1677    INTEGER :: diffmod, kk 
    16521678! 
    16531679    coeffraf = nint ( ds_parent(1) / ds_child(1) ) 
     
    16871713    endif 
    16881714! 
     1715 !   do k = lb_child(3),ub_child(3) 
     1716 !       call Agrif_Update_2D_Recursive( type_update(1:2),tabtemp(:,:,k),tempC(:,:,k), & 
     1717 !                                       indmin(1:2),indmax(1:2),                & 
     1718 !                                       lb_child(1:2),ub_child(1:2),      & 
     1719 !                                       s_child(1:2),s_parent(1:2),             & 
     1720 !                                       ds_child(1:2),ds_parent(1:2) ) 
     1721 !   enddo 
     1722 
     1723 
    16891724    do k = lb_child(3),ub_child(3) 
    1690         call Agrif_Update_2D_Recursive( type_update(1:2),tabtemp(:,:,k),tempC(:,:,k), & 
    1691                                         indmin(1:2),indmax(1:2),                & 
    1692                                         lb_child(1:2),ub_child(1:2),      & 
    1693                                         s_child(1:2),s_parent(1:2),             & 
    1694                                         ds_child(1:2),ds_parent(1:2) ) 
     1725        call Agrif_Update_2D_Recursive( type_update,tabtemp(:,:,k),tempC(:,:,k),tempC_indic(:,:,k), & 
     1726                                        indmin,indmax,                & 
     1727                                        lb_child,ub_child,      & 
     1728                                        s_child,s_parent,             & 
     1729                                        ds_child,ds_parent) 
    16951730    enddo 
     1731 
    16961732! 
    16971733    precomputedone(1) = .FALSE. 
     
    17111747            enddo 
    17121748        enddo 
     1749    else if (type_update(3) == Agrif_Update_Copy) then 
     1750    locind_child_left = lb_child(3) + nint((s_parent(3)-s_child(3))/ds_child(3)) 
     1751 
     1752        do k=indmin(3),indmax(3) 
     1753            do j = indmin(2),indmax(2) 
     1754            do i = indmin(1),indmax(1) 
     1755                tempP(i,j,k) = tabtemp(i,j,locind_child_left) 
     1756            enddo 
     1757            enddo 
     1758            locind_child_left = locind_child_left + coeffraf 
     1759        enddo 
     1760    else if (type_update(3) == Agrif_Update_Average) then 
     1761      invcoeffraf = 1./coeffraf 
     1762      tempP = 0. 
     1763      diffmod = 0 
     1764      if (mod(coeffraf,2) == 0) diffmod=1  
     1765      locind_child_left = lb_child(3) + agrif_int((s_parent(3)-s_child(3))/ds_child(3)) 
     1766      if (Agrif_UseSpecialValueInUpdate) then 
     1767        do k=indmin(3),indmax(3) 
     1768          do kk=-coeffraf/2+locind_child_left+diffmod, & 
     1769                   coeffraf/2+locind_child_left 
     1770            do j=indmin(2),indmax(2) 
     1771            do i=indmin(1),indmax(1) 
     1772               if (tabtemp(i,j,kk) /= Agrif_SpecialValueFineGrid) then 
     1773                  tempP(i,j,k) = tempP(i,j,k) + tabtemp(i,j,kk) 
     1774               endif 
     1775            enddo 
     1776            enddo 
     1777          enddo 
     1778          locind_child_left = locind_child_left + coeffraf 
     1779        enddo 
     1780      else 
     1781        do k=indmin(3),indmax(3) 
     1782          do kk=-coeffraf/2+locind_child_left+diffmod, & 
     1783                   coeffraf/2+locind_child_left 
     1784            do j=indmin(2),indmax(2) 
     1785            do i=indmin(1),indmax(1) 
     1786                  tempP(i,j,k) = tempP(i,j,k) + tabtemp(i,j,kk) 
     1787            enddo 
     1788            enddo 
     1789          enddo 
     1790          locind_child_left = locind_child_left + coeffraf 
     1791        enddo 
     1792        if (.not.Agrif_Update_Weights) tempP = tempP * invcoeffraf 
     1793      endif 
    17131794    else 
    1714         tempP = 0. 
    17151795        do j = indmin(2),indmax(2) 
    17161796        do i = indmin(1),indmax(1) 
     
    17201800                                  s_parent(3),s_child(3),               & 
    17211801                                  ds_parent(3),ds_child(3)) 
    1722 ! 
     1802 
    17231803        enddo 
    17241804        enddo 
     1805 
     1806 
    17251807    endif 
    17261808!--------------------------------------------------------------------------------------------------- 
     
    17341816!! Calls #Agrif_Update_3D_Recursive and #Agrif_UpdateBase. 
    17351817!--------------------------------------------------------------------------------------------------- 
    1736 subroutine Agrif_Update_4D_Recursive ( type_update,         & 
    1737                                        tempP, tempC,        & 
    1738                                        indmin, indmax,      & 
    1739                                        lb_child, ub_child,  & 
    1740                                         s_child,  s_parent, & 
     1818subroutine Agrif_Update_4D_Recursive ( type_update,                     & 
     1819                                       tempP, tempC, tempC_indic,       & 
     1820                                       indmin, indmax,                  & 
     1821                                       lb_child, ub_child,              & 
     1822                                       s_child,  s_parent,              & 
    17411823                                       ds_child, ds_parent ) 
    17421824!--------------------------------------------------------------------------------------------------- 
     
    17441826    integer, dimension(4),          intent(in)  :: indmin, indmax 
    17451827    integer, dimension(4),          intent(in)  :: lb_child, ub_child 
    1746     real,    dimension(4),          intent(in)  ::  s_child,  s_parent 
    1747     real,    dimension(4),          intent(in)  :: ds_child, ds_parent 
     1828    real(kind=8),    dimension(4),          intent(in)  ::  s_child,  s_parent 
     1829    real(kind=8),    dimension(4),          intent(in)  :: ds_child, ds_parent 
    17481830    real,    dimension(          & 
    17491831        indmin(1):indmax(1),     & 
     
    17551837        lb_child(2):ub_child(2), & 
    17561838        lb_child(3):ub_child(3), & 
    1757         lb_child(4):ub_child(4)),   intent(in)  :: tempC 
     1839        lb_child(4):ub_child(4)),   intent(in)  :: tempC, tempC_indic 
    17581840!--------------------------------------------------------------------------------------------------- 
    17591841    real, dimension(:,:,:,:), allocatable       :: tabtemp 
     
    17711853                                               indmin(3):indmax(3), l),     & 
    17721854                                       tempC(lb_child(1):ub_child(1),       & 
     1855                                             lb_child(2):ub_child(2),       & 
     1856                                             lb_child(3):ub_child(3), l),   & 
     1857                                       tempC_indic(lb_child(1):ub_child(1),       & 
    17731858                                             lb_child(2):ub_child(2),       & 
    17741859                                             lb_child(3):ub_child(3), l),   & 
     
    18061891!! Calls #Agrif_Update_4D_Recursive and #Agrif_UpdateBase. 
    18071892!--------------------------------------------------------------------------------------------------- 
    1808 subroutine Agrif_Update_5D_Recursive ( type_update,         & 
    1809                                        tempP, tempC,        & 
    1810                                        indmin, indmax,      & 
    1811                                        lb_child, ub_child,  & 
    1812                                         s_child,  s_parent, & 
     1893subroutine Agrif_Update_5D_Recursive ( type_update,                     & 
     1894                                       tempP, tempC, tempC_indic,       & 
     1895                                       indmin, indmax,                  & 
     1896                                       lb_child, ub_child,              & 
     1897                                       s_child,  s_parent,              & 
    18131898                                       ds_child, ds_parent ) 
    18141899!--------------------------------------------------------------------------------------------------- 
     
    18161901    integer, dimension(5),          intent(in)  :: indmin, indmax 
    18171902    integer, dimension(5),          intent(in)  :: lb_child, ub_child 
    1818     real,    dimension(5),          intent(in)  ::  s_child,  s_parent 
    1819     real,    dimension(5),          intent(in)  :: ds_child, ds_parent 
     1903    real(kind=8),    dimension(5),          intent(in)  ::  s_child,  s_parent 
     1904    real(kind=8),    dimension(5),          intent(in)  :: ds_child, ds_parent 
    18201905    real,    dimension(          & 
    18211906        indmin(1):indmax(1),     & 
     
    18291914        lb_child(3):ub_child(3), & 
    18301915        lb_child(4):ub_child(4), & 
    1831         lb_child(5):ub_child(5)),   intent(in)  :: tempC 
     1916        lb_child(5):ub_child(5)),   intent(in)  :: tempC, tempC_indic 
    18321917!--------------------------------------------------------------------------------------------------- 
    18331918    real, dimension(:,:,:,:,:), allocatable     :: tabtemp 
     
    18471932                                               indmin(4):indmax(4), m),     & 
    18481933                                       tempC(lb_child(1):ub_child(1),       & 
     1934                                             lb_child(2):ub_child(2),       & 
     1935                                             lb_child(3):ub_child(3),       & 
     1936                                             lb_child(4):ub_child(4), m),   & 
     1937                                       tempC_indic(lb_child(1):ub_child(1),       & 
    18491938                                             lb_child(2):ub_child(2),       & 
    18501939                                             lb_child(3):ub_child(3),       & 
     
    18851974!! Calls #Agrif_Update_5D_Recursive and #Agrif_UpdateBase. 
    18861975!--------------------------------------------------------------------------------------------------- 
    1887 subroutine Agrif_Update_6D_Recursive ( type_update,         & 
    1888                                        tempP, tempC,        & 
    1889                                        indmin, indmax,      & 
    1890                                        lb_child, ub_child,  & 
    1891                                         s_child,  s_parent, & 
     1976subroutine Agrif_Update_6D_Recursive ( type_update,                     & 
     1977                                       tempP, tempC, tempC_indic,       & 
     1978                                       indmin, indmax,                  & 
     1979                                       lb_child, ub_child,              & 
     1980                                       s_child,  s_parent,              & 
    18921981                                       ds_child, ds_parent ) 
    18931982!--------------------------------------------------------------------------------------------------- 
     
    18951984    integer, dimension(6),          intent(in)  :: indmin, indmax 
    18961985    integer, dimension(6),          intent(in)  :: lb_child, ub_child 
    1897     real,    dimension(6),          intent(in)  ::  s_child,  s_parent 
    1898     real,    dimension(6),          intent(in)  :: ds_child, ds_parent 
     1986    real(kind=8),    dimension(6),          intent(in)  ::  s_child,  s_parent 
     1987    real(kind=8),    dimension(6),          intent(in)  :: ds_child, ds_parent 
    18991988    real,    dimension(          & 
    19001989        indmin(1):indmax(1),     & 
     
    19101999        lb_child(4):ub_child(4), & 
    19112000        lb_child(5):ub_child(5), & 
    1912         lb_child(6):ub_child(6)),   intent(in)  :: tempC 
     2001        lb_child(6):ub_child(6)),   intent(in)  :: tempC, tempC_indic 
    19132002!--------------------------------------------------------------------------------------------------- 
    19142003    real, dimension(:,:,:,:,:,:), allocatable   :: tabtemp 
     
    19302019                                               indmin(5):indmax(5), n),     & 
    19312020                                       tempC(lb_child(1):ub_child(1),       & 
     2021                                             lb_child(2):ub_child(2),       & 
     2022                                             lb_child(3):ub_child(3),       & 
     2023                                             lb_child(4):ub_child(4),       & 
     2024                                             lb_child(5):ub_child(5), n),   & 
     2025                                       tempC_indic(lb_child(1):ub_child(1),       & 
    19322026                                             lb_child(2):ub_child(2),       & 
    19332027                                             lb_child(3):ub_child(3),       & 
     
    19822076    real, dimension(indmin:indmax),     intent(out):: parent_tab 
    19832077    real, dimension(lb_child:ub_child), intent(in) :: child_tab 
    1984     real,                               intent(in) :: s_parent,  s_child 
    1985     real,                               intent(in) :: ds_parent, ds_child 
     2078    real(kind=8),                       intent(in) :: s_parent,  s_child 
     2079    real(kind=8),                       intent(in) :: ds_parent, ds_child 
    19862080!--------------------------------------------------------------------------------------------------- 
    19872081    integer :: np       ! Length of parent array 
  • vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modupdatebasic.F90

    r5656 r10087  
    4949    integer,             intent(in)     :: np           !< Length of parent array 
    5050    integer,             intent(in)     :: nc           !< Length of child  array 
    51     real,                intent(in)     :: s_parent     !< Parent grid position (s_root = 0) 
    52     real,                intent(in)     :: s_child      !< Child  grid position (s_root = 0) 
    53     real,                intent(in)     :: ds_parent    !< Parent grid dx (ds_root = 1) 
    54     real,                intent(in)     :: ds_child     !< Child  grid dx (ds_root = 1) 
     51    real(kind=8),        intent(in)     :: s_parent     !< Parent grid position (s_root = 0) 
     52    real(kind=8),        intent(in)     :: s_child      !< Child  grid position (s_root = 0) 
     53    real(kind=8),        intent(in)     :: ds_parent    !< Parent grid dx (ds_root = 1) 
     54    real(kind=8),        intent(in)     :: ds_child     !< Child  grid dx (ds_root = 1) 
    5555!--------------------------------------------------------------------------------------------------- 
    5656    integer :: i, locind_child_left, coeffraf 
     
    8484    integer,             intent(in)     :: np           !< Length of parent array 
    8585    integer,             intent(in)     :: nc           !< Length of child  array 
    86     real,                intent(in)     :: s_parent     !< Parent grid position (s_root = 0) 
    87     real,                intent(in)     :: s_child      !< Child  grid position (s_root = 0) 
    88     real,                intent(in)     :: ds_parent    !< Parent grid dx (ds_root = 1) 
    89     real,                intent(in)     :: ds_child     !< Child  grid dx (ds_root = 1) 
     86    real(kind=8),        intent(in)     :: s_parent     !< Parent grid position (s_root = 0) 
     87    real(kind=8),        intent(in)     :: s_child      !< Child  grid position (s_root = 0) 
     88    real(kind=8),        intent(in)     :: ds_parent    !< Parent grid dx (ds_root = 1) 
     89    real(kind=8),        intent(in)     :: ds_child     !< Child  grid dx (ds_root = 1) 
    9090    integer,             intent(in)     :: dir          !< Direction 
    9191!--------------------------------------------------------------------------------------------------- 
     
    157157    REAL, DIMENSION(nc), intent(in)     :: y 
    158158    INTEGER,             intent(in)     :: np,nc 
    159     REAL,                intent(in)     :: s_parent,  s_child 
    160     REAL,                intent(in)     :: ds_parent, ds_child 
     159    REAL(kind=8),        intent(in)     :: s_parent,  s_child 
     160    REAL(kind=8),        intent(in)     :: ds_parent, ds_child 
    161161! 
    162162    INTEGER :: i, ii, locind_child_left, coeffraf 
    163     REAL    :: xpos, invcoeffraf 
     163    REAL(kind=8)    :: xpos 
     164    REAL ::  invcoeffraf 
    164165    INTEGER :: nbnonnuls 
    165166    INTEGER :: diffmod 
     
    229230!--------------------------------------------------------------------------------------------------- 
    230231    INTEGER, intent(in) :: nc2, np, nc 
    231     REAL,    intent(in) :: s_parent,  s_child 
    232     REAL,    intent(in) :: ds_parent, ds_child 
     232    REAL(kind=8),    intent(in) :: s_parent,  s_child 
     233    REAL(kind=8),    intent(in) :: ds_parent, ds_child 
    233234    INTEGER, intent(in) :: dir 
    234235! 
    235236    INTEGER, DIMENSION(:,:), ALLOCATABLE :: indchildaverage_tmp 
    236237    INTEGER :: i, locind_child_left, coeffraf 
    237     REAL    :: xpos 
     238    REAL(kind=8)    :: xpos 
    238239    INTEGER :: diffmod 
    239240! 
     
    281282    REAL, DIMENSION(nc), intent(in)     :: y 
    282283    INTEGER,             intent(in)     :: np, nc 
    283     REAL,                intent(in)     :: s_parent,  s_child 
    284     REAL,                intent(in)     :: ds_parent, ds_child 
     284    REAL(kind=8),                intent(in)     :: s_parent,  s_child 
     285    REAL(kind=8),                intent(in)     :: ds_parent, ds_child 
    285286    INTEGER,             intent(in)     :: dir 
    286287! 
     
    311312    ELSE 
    312313! 
    313 !CDIR NOLOOPCHG 
    314         do  j = 1,coeffraf 
    315 !CDIR VECTOR 
    316             do i= 1,np 
     314 
     315        do i = 1,np 
     316        do j = 1,coeffraf 
    317317                x(i) = x(i) + y(indchildaverage(i,dir) + j-1 ) 
    318             enddo 
     318        enddo 
    319319        enddo 
    320320        IF (.not.Agrif_Update_Weights) THEN 
     
    338338    real, dimension(nc), intent(in)     :: y 
    339339    integer,             intent(in)     :: np, nc 
    340     real,                intent(in)     :: s_parent,  s_child 
    341     real,                intent(in)     :: ds_parent, ds_child 
    342 !--------------------------------------------------------------------------------------------------- 
    343     REAL    :: xpos, xposfin 
     340    real(kind=8),                intent(in)     :: s_parent,  s_child 
     341    real(kind=8),                intent(in)     :: ds_parent, ds_child 
     342!--------------------------------------------------------------------------------------------------- 
     343    REAL(kind=8)    :: xpos, xposfin 
    344344    INTEGER :: i, ii, diffmod 
    345345    INTEGER :: it1, it2 
  • vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modutil.F90

    r10084 r10087  
    22! $Id$ 
    33! 
    4 !     Agrif (Adaptive Grid Refinement In Fortran) 
     4!     AGRIF (Adaptive Grid Refinement In Fortran) 
    55! 
    66!     Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr) 
     
    1919!     You should have received a copy of the GNU General Public License 
    2020!     along with this program; if not, write to the Free Software 
    21 !     Foundation, Inc., 59 Temple Place-  Suite 330, Boston, MA 02111-1307, USA. 
     21!     Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA. 
    2222! 
    2323!> Module Agrif_Util 
    24 !! 
    25 !! This module contains the two procedures called in the main program : 
    26 !! - #Agrif_Init_Grids allows the initialization of the root coarse grid 
    27 !! - #Agrif_Step allows the creation of the grid hierarchy and the management of the time integration. 
     24!> 
     25!>  
     26! 
    2827! 
    2928module Agrif_Util 
    3029! 
    31     use Agrif_Clustering 
    32     use Agrif_BcFunction 
    33     use Agrif_seq 
    34     use Agrif_Link 
     30  use Agrif_User_Hierarchy 
     31  use Agrif_User_Variables 
     32  use Agrif_user_Functions 
     33  use Agrif_user_Interpolation 
     34  use Agrif_user_Update 
     35  
    3536! 
    3637    implicit none 
    3738! 
    38     abstract interface 
    39         subroutine step_proc() 
    40         end subroutine step_proc 
    41     end interface 
    42 ! 
    4339contains 
    4440! 
    45 !=================================================================================================== 
    46 !  subroutine Agrif_Step 
    47 ! 
    48 !> Creates the grid hierarchy and manages the time integration procedure. 
    49 !> It is called in the main program. 
    50 !> Calls subroutines #Agrif_Regrid and #Agrif_Integrate. 
    51 !--------------------------------------------------------------------------------------------------- 
    52 subroutine Agrif_Step ( procname ) 
    53 !--------------------------------------------------------------------------------------------------- 
    54     procedure(step_proc)    :: procname     !< subroutine to call on each grid 
    55     type(agrif_grid), pointer :: ref_grid 
    56 ! 
    57 ! Set the clustering variables 
    58     call Agrif_clustering_def() 
    59 ! 
    60 ! Creation and initialization of the grid hierarchy 
    61     if ( Agrif_USE_ONLY_FIXED_GRIDS == 1 ) then 
    62 ! 
    63         if ( (Agrif_Mygrid % ngridstep == 0) .AND. (.not. Agrif_regrid_has_been_done) ) then 
    64             call Agrif_Regrid() 
    65             Agrif_regrid_has_been_done = .TRUE. 
    66         endif 
    67 ! 
    68     else 
    69 ! 
    70         if (mod(Agrif_Mygrid % ngridstep,Agrif_Regridding) == 0) then 
    71             call Agrif_Regrid() 
    72         endif 
    73 ! 
    74     endif 
    75 ! 
    76 ! Time integration of the grid hierarchy 
    77     if (agrif_coarse) then 
    78       ref_grid => agrif_coarsegrid 
    79     else 
    80       ref_grid => agrif_mygrid 
    81     endif 
    82     if ( Agrif_Parallel_sisters ) then 
    83         call Agrif_Integrate_Parallel(ref_grid,procname) 
    84     else 
    85         call Agrif_Integrate(ref_grid,procname) 
    86     endif 
    87 ! 
    88     if ( ref_grid%child_list%nitems > 0 ) call Agrif_Instance(ref_grid) 
    89 !--------------------------------------------------------------------------------------------------- 
    90 end subroutine Agrif_Step 
    91 !=================================================================================================== 
    92 ! 
    93 !=================================================================================================== 
    94 !  subroutine Agrif_Step_Child 
    95 ! 
    96 !> Apply 'procname' to each grid of the hierarchy 
    97 !--------------------------------------------------------------------------------------------------- 
    98 subroutine Agrif_Step_Child ( procname ) 
    99 !--------------------------------------------------------------------------------------------------- 
    100     procedure(step_proc)    :: procname     !< subroutine to call on each grid 
    101 ! 
    102     if ( Agrif_Parallel_sisters ) then 
    103         call Agrif_Integrate_Child_Parallel(Agrif_Mygrid,procname) 
    104     else 
    105         call Agrif_Integrate_Child(Agrif_Mygrid,procname) 
    106     endif 
    107 ! 
    108     if ( Agrif_Mygrid%child_list%nitems > 0 ) call Agrif_Instance(Agrif_Mygrid) 
    109 !--------------------------------------------------------------------------------------------------- 
    110 end subroutine Agrif_Step_Child 
    111 !=================================================================================================== 
    112 ! 
    113 !=================================================================================================== 
    114 !  subroutine Agrif_Regrid 
    115 ! 
    116 !> Creates the grid hierarchy from fixed grids and adaptive mesh refinement. 
    117 !--------------------------------------------------------------------------------------------------- 
    118 subroutine Agrif_Regrid ( procname ) 
    119 !--------------------------------------------------------------------------------------------------- 
    120     procedure(init_proc), optional    :: procname     !< Initialisation subroutine (Default: Agrif_InitValues) 
    121 ! 
    122     type(Agrif_Rectangle), pointer     :: coarsegrid_fixed 
    123     type(Agrif_Rectangle), pointer     :: coarsegrid_moving 
    124     integer                            :: i, j 
    125     integer :: nunit 
    126     logical :: BEXIST 
    127     TYPE(Agrif_Rectangle)            :: newrect    ! Pointer on a new grid 
    128     integer :: is_coarse, rhox, rhoy, rhoz, rhot 
    129 ! 
    130     if ( Agrif_USE_ONLY_FIXED_GRIDS == 0 ) & 
    131         call Agrif_detect_all(Agrif_Mygrid)     ! Detection of areas to be refined 
    132 ! 
    133     allocate(coarsegrid_fixed) 
    134     allocate(coarsegrid_moving) 
    135 ! 
    136     if ( Agrif_USE_ONLY_FIXED_GRIDS == 0 ) & 
    137         call Agrif_Cluster_All(Agrif_Mygrid,coarsegrid_moving) ! Clustering 
    138 ! 
    139     if ( Agrif_USE_FIXED_GRIDS == 1 .OR. Agrif_USE_ONLY_FIXED_GRIDS == 1 ) then 
    140 ! 
    141         if (Agrif_Mygrid % ngridstep == 0) then 
    142 !             
    143             nunit = Agrif_Get_Unit() 
    144             open(nunit, file='AGRIF_FixedGrids.in', form='formatted', status="old", ERR=99) 
    145             if (agrif_coarse) then ! SKIP the coarse grid declaration 
    146                 if (Agrif_Probdim == 3) then 
    147                     read(nunit,*) is_coarse, rhox, rhoy, rhoz, rhot 
    148                 elseif (Agrif_Probdim == 2) then 
    149                     read(nunit,*) is_coarse, rhox, rhoy, rhot 
    150                 elseif (Agrif_Probdim == 2) then 
    151                     read(nunit,*) is_coarse, rhox, rhot 
    152                 endif 
    153             endif 
    154 !           Creation of the grid hierarchy from the Agrif_FixedGrids.in file 
    155             do i = 1,Agrif_Probdim 
    156                 coarsegrid_fixed % imin(i) = 1 
    157                 coarsegrid_fixed % imax(i) = Agrif_Mygrid % nb(i) + 1 
    158             enddo 
    159             j = 1 
    160             call Agrif_Read_Fix_Grd(coarsegrid_fixed,j,nunit) 
    161             close(nunit) 
    162 ! 
    163             call Agrif_gl_clear(Agrif_oldmygrid) 
    164 ! 
    165 !           Creation of the grid hierarchy from coarsegrid_fixed 
    166             call Agrif_Create_Grids(Agrif_Mygrid,coarsegrid_fixed) 
    167              
    168         else 
    169             call Agrif_gl_copy(Agrif_oldmygrid, Agrif_Mygrid % child_list) 
    170         endif 
    171     else 
    172         call Agrif_gl_copy(Agrif_oldmygrid, Agrif_Mygrid % child_list) 
    173         call Agrif_gl_clear(Agrif_Mygrid % child_list) 
    174     endif 
    175 ! 
    176     if ( Agrif_USE_ONLY_FIXED_GRIDS == 0 ) then 
    177 ! 
    178         call Agrif_Save_All(Agrif_oldmygrid) 
    179         call Agrif_Free_before_All(Agrif_oldmygrid) 
    180 ! 
    181 !       Creation of the grid hierarchy from coarsegrid_moving 
    182         call Agrif_Create_Grids(Agrif_Mygrid,coarsegrid_moving) 
    183 ! 
    184     endif 
    185 ! 
    186 !   Initialization of the grid hierarchy by copy or interpolation 
    187 ! 
    188 #if defined AGRIF_MPI 
    189     if ( Agrif_Parallel_sisters ) then 
    190         call Agrif_Init_Hierarchy_Parallel_1(Agrif_Mygrid) 
    191         call Agrif_Init_Hierarchy_Parallel_2(Agrif_Mygrid,procname) 
    192     else 
    193         call Agrif_Init_Hierarchy(Agrif_Mygrid,procname) 
    194     endif 
    195 #else 
    196         call Agrif_Init_Hierarchy(Agrif_Mygrid,procname) 
    197 #endif 
    198 ! 
    199     if ( Agrif_USE_ONLY_FIXED_GRIDS == 0 ) call Agrif_Free_after_All(Agrif_oldmygrid) 
    200 ! 
    201     Agrif_regrid_has_been_done = .TRUE. 
    202 ! 
    203     call Agrif_Instance( Agrif_Mygrid ) 
    204 ! 
    205     deallocate(coarsegrid_fixed) 
    206     deallocate(coarsegrid_moving) 
    207 ! 
    208     return 
    209 ! 
    210 !     Opening error 
    211 ! 
    212 99  INQUIRE(FILE='AGRIF_FixedGrids.in',EXIST=BEXIST) 
    213     if (.not. BEXIST) then 
    214         print*,'ERROR : File AGRIF_FixedGrids.in not found.' 
    215         STOP 
    216     else 
    217         print*,'Error opening file AGRIF_FixedGrids.in' 
    218         STOP 
    219     endif 
    220 !--------------------------------------------------------------------------------------------------- 
    221 end subroutine Agrif_Regrid 
    222 !=================================================================================================== 
    223 ! 
    224 !=================================================================================================== 
    225 !  subroutine Agrif_detect_All 
    226 ! 
    227 !> Detects areas to be refined. 
    228 !--------------------------------------------------------------------------------------------------- 
    229 recursive subroutine Agrif_detect_all ( g ) 
    230 !--------------------------------------------------------------------------------------------------- 
    231     TYPE(Agrif_Grid),  pointer  :: g        !< Pointer on the current grid 
    232 ! 
    233     Type(Agrif_PGrid), pointer  :: parcours ! Pointer for the recursive procedure 
    234     integer, DIMENSION(3)       :: size 
    235     integer                     :: i 
    236     real                        :: g_eps 
    237 ! 
    238     parcours => g % child_list % first 
    239 ! 
    240 !   To be positioned on the finer grids of the grid hierarchy 
    241 ! 
    242     do while (associated(parcours)) 
    243         call Agrif_detect_all(parcours % gr) 
    244         parcours => parcours % next 
    245     enddo 
    246 ! 
    247     g_eps = huge(1.) 
    248     do i = 1,Agrif_Probdim 
    249         g_eps = min(g_eps, g % Agrif_dx(i)) 
    250     enddo 
    251 ! 
    252     g_eps = g_eps / 100. 
    253 ! 
    254     if ( Agrif_Probdim == 1 ) g%tabpoint1D = 0 
    255     if ( Agrif_Probdim == 2 ) g%tabpoint2D = 0 
    256     if ( Agrif_Probdim == 3 ) g%tabpoint3D = 0 
    257 ! 
    258     do i = 1,Agrif_Probdim 
    259         if ( g%Agrif_dx(i)/Agrif_coeffref(i) < (Agrif_mind(i)-g_eps) ) return 
    260     enddo 
    261 ! 
    262     call Agrif_instance(g) 
    263 ! 
    264 !   Detection (Agrif_detect is a users routine) 
    265 ! 
    266     do i = 1,Agrif_Probdim 
    267         size(i) = g % nb(i) + 1 
    268     enddo 
    269 ! 
    270     SELECT CASE (Agrif_Probdim) 
    271     CASE (1) 
    272         call Agrif_detect(g%tabpoint1D,size) 
    273     CASE (2) 
    274         call Agrif_detect(g%tabpoint2D,size) 
    275     CASE (3) 
    276         call Agrif_detect(g%tabpoint3D,size) 
    277     END SELECT 
    278 ! 
    279 !   Addition of the areas detected on the child grids 
    280 ! 
    281     parcours => g % child_list % first 
    282 ! 
    283     do while (associated(parcours)) 
    284         call Agrif_Add_detected_areas(g,parcours % gr) 
    285         parcours => parcours % next 
    286     enddo 
    287 !--------------------------------------------------------------------------------------------------- 
    288 end subroutine Agrif_detect_all 
    289 !=================================================================================================== 
    290 ! 
    291 !=================================================================================================== 
    292 !  subroutine Agrif_Add_detected_areas 
    293 ! 
    294 !> Adds on the parent grid the areas detected on its child grids 
    295 !--------------------------------------------------------------------------------------------------- 
    296 subroutine Agrif_Add_detected_areas ( parentgrid, childgrid ) 
    297 !--------------------------------------------------------------------------------------------------- 
    298     Type(Agrif_Grid), pointer   :: parentgrid 
    299     Type(Agrif_Grid), pointer   :: childgrid 
    300 ! 
    301     integer :: i,j,k 
    302 ! 
    303     do i = 1,childgrid%nb(1)+1 
    304         if ( Agrif_Probdim == 1 ) then 
    305             if (childgrid%tabpoint1D(i)==1) then 
    306                 parentgrid%tabpoint1D(childgrid%ix(1)+(i-1)/Agrif_Coeffref(1)) = 1 
    307             endif 
    308         else 
    309             do j=1,childgrid%nb(2)+1 
    310                 if (Agrif_Probdim==2) then 
    311                     if (childgrid%tabpoint2D(i,j)==1) then 
    312                         parentgrid%tabpoint2D(                       & 
    313                             childgrid%ix(1)+(i-1)/Agrif_Coeffref(1), & 
    314                             childgrid%ix(2)+(j-1)/Agrif_Coeffref(2)) = 1 
    315                     endif 
    316                 else 
    317                     do k=1,childgrid%nb(3)+1 
    318                         if (childgrid%tabpoint3D(i,j,k)==1) then 
    319                             parentgrid%tabpoint3D(                       & 
    320                                 childgrid%ix(1)+(i-1)/Agrif_Coeffref(1), & 
    321                                 childgrid%ix(2)+(j-1)/Agrif_Coeffref(2), & 
    322                                 childgrid%ix(3)+(k-1)/Agrif_Coeffref(3)) = 1 
    323                         endif 
    324                     enddo 
    325                 endif 
    326             enddo 
    327         endif 
    328     enddo 
    329 !--------------------------------------------------------------------------------------------------- 
    330 end subroutine Agrif_Add_detected_areas 
    331 !=================================================================================================== 
    332 ! 
    333 !=================================================================================================== 
    334 !  subroutine Agrif_Free_before_All 
    335 !--------------------------------------------------------------------------------------------------- 
    336 recursive subroutine Agrif_Free_before_All ( gridlist ) 
    337 !--------------------------------------------------------------------------------------------------- 
    338     Type(Agrif_Grid_List), intent(inout)    :: gridlist !< Grid list 
    339 ! 
    340     Type(Agrif_PGrid), pointer   :: parcours ! Pointer for the recursive procedure 
    341 ! 
    342     parcours => gridlist % first 
    343 ! 
    344     do while (associated(parcours)) 
    345 ! 
    346         if (.not. parcours%gr%fixed) then 
    347             call Agrif_Free_data_before(parcours%gr) 
    348             parcours % gr % oldgrid = .TRUE. 
    349         endif 
    350 ! 
    351         call Agrif_Free_before_all (parcours % gr % child_list) 
    352 ! 
    353         parcours => parcours % next 
    354 ! 
    355     enddo 
    356 !--------------------------------------------------------------------------------------------------- 
    357 end subroutine Agrif_Free_before_All 
    358 !=================================================================================================== 
    359 ! 
    360 !=================================================================================================== 
    361 !  subroutine Agrif_Save_All 
    362 !--------------------------------------------------------------------------------------------------- 
    363 recursive subroutine Agrif_Save_All ( gridlist ) 
    364 !--------------------------------------------------------------------------------------------------- 
    365     type(Agrif_Grid_List), intent(inout)    :: gridlist !< Grid list 
    366 ! 
    367     type(Agrif_PGrid), pointer   :: parcours ! Pointer for the recursive procedure 
    368 ! 
    369     parcours => gridlist % first 
    370 ! 
    371     do while (associated(parcours)) 
    372 ! 
    373         if (.not. parcours%gr%fixed) then 
    374             call Agrif_Instance(parcours%gr) 
    375             call Agrif_Before_Regridding() 
    376             parcours % gr % oldgrid = .TRUE. 
    377         endif 
    378 ! 
    379         call Agrif_Save_All(parcours % gr % child_list) 
    380 ! 
    381         parcours => parcours % next 
    382 ! 
    383       enddo 
    384 !--------------------------------------------------------------------------------------------------- 
    385 end subroutine Agrif_Save_All 
    386 !=================================================================================================== 
    387 ! 
    388 !=================================================================================================== 
    389 !  subroutine Agrif_Free_after_All 
    390 !--------------------------------------------------------------------------------------------------- 
    391 recursive subroutine Agrif_Free_after_All ( gridlist ) 
    392 !--------------------------------------------------------------------------------------------------- 
    393     Type(Agrif_Grid_List), intent(inout)    :: gridlist       !< Grid list to free 
    394 ! 
    395     Type(Agrif_PGrid), pointer  :: parcours ! Pointer for the recursive proced 
    396     Type(Agrif_PGrid), pointer  :: preparcours 
    397     Type(Agrif_PGrid), pointer  :: preparcoursini 
    398 ! 
    399     allocate(preparcours) 
    400 ! 
    401     preparcoursini => preparcours 
    402 ! 
    403     nullify(preparcours % gr) 
    404 ! 
    405     preparcours % next => gridlist % first 
    406     parcours => gridlist % first 
    407 ! 
    408     do while (associated(parcours)) 
    409 ! 
    410         if ( (.NOT. parcours%gr % fixed) .AND. (parcours%gr % oldgrid) ) then 
    411             call Agrif_Free_data_after(parcours%gr) 
    412         endif 
    413 ! 
    414         call Agrif_Free_after_all( parcours%gr % child_list ) 
    415 ! 
    416         if (parcours % gr % oldgrid) then 
    417             deallocate(parcours % gr) 
    418             preparcours % next => parcours % next 
    419             deallocate(parcours) 
    420             parcours => preparcours % next 
    421         else 
    422             preparcours => preparcours % next 
    423             parcours => parcours % next 
    424         endif 
    425 ! 
    426     enddo 
    427 ! 
    428     deallocate(preparcoursini) 
    429 !--------------------------------------------------------------------------------------------------- 
    430 end subroutine Agrif_Free_after_All 
    431 !=================================================================================================== 
    432 ! 
    433 !=================================================================================================== 
    434 !  subroutine Agrif_Integrate 
    435 ! 
    436 !> Manages the time integration of the grid hierarchy. 
    437 !! Recursive subroutine and call on subroutines Agrif_Init::Agrif_Instance and #Agrif_Step 
    438 !--------------------------------------------------------------------------------------------------- 
    439 recursive subroutine Agrif_Integrate ( g, procname ) 
    440 !--------------------------------------------------------------------------------------------------- 
    441     type(Agrif_Grid), pointer   :: g        !< Pointer on the current grid 
    442     procedure(step_proc)        :: procname !< Subroutine to call on each grid 
    443 ! 
    444     type(Agrif_PGrid), pointer  :: parcours ! Pointer for the recursive procedure 
    445     integer                     :: nbt      ! Number of time steps of the current grid 
    446     integer                     :: i, k 
    447 ! 
    448 !   Instanciation of the variables of the current grid 
    449 !    if ( g % fixedrank /= 0 ) then 
    450         call Agrif_Instance(g) 
    451 !    endif 
    452 ! 
    453 !   One step on the current grid 
    454 ! 
    455     call procname () 
    456 ! 
    457 !   Number of time steps on the current grid 
    458 ! 
    459     g%ngridstep = g % ngridstep + 1 
    460     parcours => g % child_list % first 
    461 ! 
    462 !   Recursive procedure for the time integration of the grid hierarchy 
    463     do while (associated(parcours)) 
    464 ! 
    465 !       Instanciation of the variables of the current grid 
    466         call Agrif_Instance(parcours % gr) 
    467 ! 
    468 !       Number of time steps 
    469         nbt = 1 
    470         do i = 1,Agrif_Probdim 
    471             nbt = max(nbt, parcours % gr % timeref(i)) 
    472         enddo 
    473 ! 
    474         do k = 1,nbt 
    475             call Agrif_Integrate(parcours % gr, procname) 
    476         enddo 
    477 ! 
    478         parcours => parcours % next 
    479 ! 
    480     enddo 
    481 !--------------------------------------------------------------------------------------------------- 
    482 end subroutine Agrif_Integrate 
    483 !=================================================================================================== 
    484 ! 
    485 !=================================================================================================== 
    486 !  subroutine Agrif_Integrate_Parallel 
    487 ! 
    488 !> Manages the time integration of the grid hierarchy in parallel 
    489 !! Recursive subroutine and call on subroutines Agrif_Init::Agrif_Instance and #Agrif_Step 
    490 !--------------------------------------------------------------------------------------------------- 
    491 recursive subroutine Agrif_Integrate_Parallel ( g, procname ) 
    492 !--------------------------------------------------------------------------------------------------- 
    493     type(Agrif_Grid), pointer   :: g        !< Pointer on the current grid 
    494     procedure(step_proc)        :: procname !< Subroutine to call on each grid 
    495 ! 
    496 #if defined AGRIF_MPI 
    497     type(Agrif_PGrid), pointer  :: gridp    ! Pointer for the recursive procedure 
    498     integer                     :: nbt      ! Number of time steps of the current grid 
    499     integer                     :: i, k, is 
    500 ! 
    501 !   Instanciation of the variables of the current grid 
    502     if ( g % fixedrank /= 0 ) then 
    503         call Agrif_Instance(g) 
    504     endif 
    505 ! 
    506 ! One step on the current grid 
    507     call procname () 
    508 ! 
    509 ! Number of time steps on the current grid 
    510     g % ngridstep = g % ngridstep + 1 
    511 ! 
    512 ! Continue only if the grid has defined sequences of child integrations. 
    513     if ( .not. associated(g % child_seq) ) return 
    514 ! 
    515     do is = 1, g % child_seq % nb_seqs 
    516 ! 
    517 !     For each sequence, a given processor does integrate only on grid. 
    518         gridp => Agrif_seq_select_child(g,is) 
    519 ! 
    520 !     Instanciation of the variables of the current grid 
    521         call Agrif_Instance(gridp % gr) 
    522 ! 
    523 !     Number of time steps 
    524         nbt = 1 
    525         do i = 1,Agrif_Probdim 
    526             nbt = max(nbt, gridp % gr % timeref(i)) 
    527         enddo 
    528 ! 
    529         do k = 1,nbt 
    530             call Agrif_Integrate_Parallel(gridp % gr, procname) 
    531         enddo 
    532 ! 
    533     enddo 
    534 #else 
    535     call Agrif_Integrate( g, procname ) 
    536 #endif 
    537 !--------------------------------------------------------------------------------------------------- 
    538 end subroutine Agrif_Integrate_Parallel 
    539 !=================================================================================================== 
    540 ! 
    541 ! 
    542 !=================================================================================================== 
    543 !  subroutine Agrif_Integrate_ChildGrids 
    544 ! 
    545 !> Manages the time integration of the grid hierarchy. 
    546 !! Call the subroutine procname on each child grid of the current grid 
    547 !--------------------------------------------------------------------------------------------------- 
    548 recursive subroutine Agrif_Integrate_ChildGrids ( procname ) 
    549 !--------------------------------------------------------------------------------------------------- 
    550     procedure(step_proc)        :: procname !< Subroutine to call on each grid 
    551 ! 
    552     type(Agrif_PGrid), pointer  :: parcours ! Pointer for the recursive procedure 
    553     integer                     :: nbt      ! Number of time steps of the current grid 
    554     integer                     :: i, k, is 
    555     type(Agrif_Grid)                    , pointer :: save_grid 
    556     type(Agrif_PGrid), pointer  :: gridp    ! Pointer for the recursive procedure 
    557      
    558     save_grid => Agrif_Curgrid 
    55941 
    560 ! Number of time steps on the current grid 
    561     save_grid % ngridstep = save_grid % ngridstep + 1 
    562      
    563 #ifdef AGRIF_MPI 
    564     if ( .not. Agrif_Parallel_sisters ) then 
    565 #endif 
    566     parcours => save_grid % child_list % first 
    567 ! 
    568 !   Recursive procedure for the time integration of the grid hierarchy 
    569     do while (associated(parcours)) 
    570 ! 
    571 !       Instanciation of the variables of the current grid 
    572         call Agrif_Instance(parcours % gr) 
    573 ! 
    574 !       Number of time steps 
    575         nbt = 1 
    576         do i = 1,Agrif_Probdim 
    577             nbt = max(nbt, parcours % gr % timeref(i)) 
    578         enddo 
    579 ! 
    580         do k = 1,nbt 
    581             call procname() 
    582         enddo 
    583 ! 
    584         parcours => parcours % next 
    585 ! 
    586     enddo 
    587  
    588 #ifdef AGRIF_MPI 
    589     else 
    590 ! Continue only if the grid has defined sequences of child integrations. 
    591     if ( .not. associated(save_grid % child_seq) ) return 
    592 ! 
    593     do is = 1, save_grid % child_seq % nb_seqs 
    594 ! 
    595 !     For each sequence, a given processor does integrate only on grid. 
    596         gridp => Agrif_seq_select_child(save_grid,is) 
    597 ! 
    598 !     Instanciation of the variables of the current grid 
    599         call Agrif_Instance(gridp % gr) 
    600 ! 
    601 !     Number of time steps 
    602         nbt = 1 
    603         do i = 1,Agrif_Probdim 
    604             nbt = max(nbt, gridp % gr % timeref(i)) 
    605         enddo 
    606 ! 
    607         do k = 1,nbt 
    608             call procname() 
    609         enddo 
    610 ! 
    611     enddo 
    612     endif 
    613 #endif  
    614  
    615     call Agrif_Instance(save_grid) 
    616      
    617 !--------------------------------------------------------------------------------------------------- 
    618 end subroutine Agrif_Integrate_ChildGrids 
    619 !=================================================================================================== 
    620 !=================================================================================================== 
    621 !  subroutine Agrif_Integrate_Child 
    622 ! 
    623 !> Manages the time integration of the grid hierarchy. 
    624 !! Recursive subroutine and call on subroutines Agrif_Instance & Agrif_Step. 
    625 !--------------------------------------------------------------------------------------------------- 
    626 recursive subroutine Agrif_Integrate_Child ( g, procname ) 
    627 !--------------------------------------------------------------------------------------------------- 
    628     type(Agrif_Grid), pointer   :: g        !< Pointer on the current grid 
    629     procedure(step_proc)        :: procname !< Subroutine to call on each grid 
    630 ! 
    631     type(Agrif_PGrid), pointer  :: parcours ! Pointer for the recursive procedure 
    632 ! 
    633 !   One step on the current grid 
    634 ! 
    635     call procname () 
    636 ! 
    637 !   Number of time steps on the current grid 
    638 ! 
    639     parcours => g % child_list % first 
    640 ! 
    641 !   Recursive procedure for the time integration of the grid hierarchy 
    642     do while (associated(parcours)) 
    643 ! 
    644 !       Instanciation of the variables of the current grid 
    645         call Agrif_Instance(parcours % gr) 
    646         call Agrif_Integrate_Child (parcours % gr, procname) 
    647         parcours => parcours % next 
    648 ! 
    649     enddo 
    650 !--------------------------------------------------------------------------------------------------- 
    651 end subroutine Agrif_Integrate_Child 
    652 !=================================================================================================== 
    653 ! 
    654 !=================================================================================================== 
    655 !  subroutine Agrif_Integrate_Child_Parallel 
    656 ! 
    657 !> Manages the time integration of the grid hierarchy. 
    658 !! Recursive subroutine and call on subroutines Agrif_Instance & Agrif_Step. 
    659 !--------------------------------------------------------------------------------------------------- 
    660 recursive subroutine Agrif_Integrate_Child_Parallel ( g, procname ) 
    661 !--------------------------------------------------------------------------------------------------- 
    662     type(Agrif_Grid), pointer   :: g        !< Pointer on the current grid 
    663     procedure(step_proc)        :: procname !< Subroutine to call on each grid 
    664 ! 
    665 #if defined AGRIF_MPI 
    666     type(Agrif_PGrid), pointer  :: gridp    ! Pointer for the recursive procedure 
    667     integer                     :: is 
    668 ! 
    669 ! Instanciation of the variables of the current grid 
    670     call Agrif_Instance(g) 
    671 ! 
    672 ! One step on the current grid 
    673     call procname () 
    674 ! 
    675 ! Continue only if the grid has defined sequences of child integrations. 
    676     if ( .not. associated(g % child_seq) ) return 
    677 ! 
    678     do is = 1, g % child_seq % nb_seqs 
    679 ! 
    680 !     For each sequence, a given processor does integrate only on grid. 
    681         gridp => Agrif_seq_select_child(g,is) 
    682         call Agrif_Integrate_Child_Parallel(gridp % gr, procname) 
    683 ! 
    684     enddo 
    685 ! 
    686     call Agrif_Instance(g) 
    687 #else 
    688     call Agrif_Integrate_Child( g, procname ) 
    689 #endif 
    690 !--------------------------------------------------------------------------------------------------- 
    691 end subroutine Agrif_Integrate_Child_Parallel 
    692 !=================================================================================================== 
    693 ! 
    694 !=================================================================================================== 
    695 !  subroutine Agrif_Init_Grids 
    696 ! 
    697 !> Initializes the root coarse grid pointed by Agrif_Mygrid. It is called in the main program. 
    698 !--------------------------------------------------------------------------------------------------- 
    699 subroutine Agrif_Init_Grids ( procname1, procname2 ) 
    700 !--------------------------------------------------------------------------------------------------- 
    701     procedure(typedef_proc), optional   :: procname1 !< (Default: Agrif_probdim_modtype_def) 
    702     procedure(alloc_proc),   optional   :: procname2 !< (Default: Agrif_Allocationcalls) 
    703 ! 
    704     integer :: i, ierr_allocate, nunit 
    705     integer :: is_coarse, rhox,rhoy,rhoz,rhot 
    706     logical :: BEXIST 
    707 ! 
    708     if (present(procname1)) Then 
    709         call procname1() 
    710     else 
    711         call Agrif_probdim_modtype_def() 
    712     endif 
    713 ! 
    714  
    715 ! TEST FOR COARSE GRID (GRAND MOTHER GRID) in AGRIF_FixedGrids.in 
    716     nunit = Agrif_Get_Unit() 
    717     open(nunit, file='AGRIF_FixedGrids.in', form='formatted', status="old", ERR=98) 
    718     if (Agrif_Probdim == 3) then 
    719        read(nunit,*) is_coarse, rhox, rhoy, rhoz, rhot 
    720     elseif (Agrif_Probdim == 2) then 
    721        read(nunit,*) is_coarse, rhox, rhoy, rhot 
    722     elseif (Agrif_Probdim == 2) then 
    723        read(nunit,*) is_coarse, rhox, rhot 
    724     endif 
    725     if (is_coarse == -1) then 
    726        agrif_coarse = .TRUE. 
    727        if (Agrif_Probdim == 3) then 
    728           coarse_spaceref(1:3)=(/rhox,rhoy,rhoz/) 
    729        elseif (Agrif_Probdim == 2) then 
    730           coarse_spaceref(1:2)=(/rhox,rhoy/) 
    731        elseif (Agrif_Probdim == 2) then 
    732           coarse_spaceref(1:1)=(/rhox/) 
    733        endif 
    734        coarse_timeref(1:Agrif_Probdim) = rhot 
    735     endif 
    736     close(nunit) 
    737      
    738     Agrif_UseSpecialValue = .FALSE. 
    739     Agrif_UseSpecialValueFineGrid = .FALSE. 
    740     Agrif_SpecialValue = 0. 
    741     Agrif_SpecialValueFineGrid = 0. 
    742 ! 
    743     allocate(Agrif_Mygrid) 
    744     allocate(Agrif_OldMygrid) 
    745 ! 
    746 !   Space and time refinement factors are set to 1 on the root grid 
    747 ! 
    748     do i = 1,Agrif_Probdim 
    749         Agrif_Mygrid % spaceref(i) = coarse_spaceref(i) 
    750         Agrif_Mygrid % timeref(i)  = coarse_timeref(i) 
    751     enddo 
    752 ! 
    753 !   Initialization of the number of time steps 
    754     Agrif_Mygrid % ngridstep = 0 
    755     Agrif_Mygrid % grid_id   = 0 
    756 ! 
    757 !   No parent grid for the root coarse grid 
    758     nullify(Agrif_Mygrid % parent) 
    759 ! 
    760 !   Initialization of the minimum positions, global abscissa and space steps 
    761     do i = 1, Agrif_Probdim 
    762         Agrif_Mygrid % ix(i) = 1 
    763         Agrif_Mygrid % Agrif_x(i)  = 0. 
    764         Agrif_Mygrid % Agrif_dx(i) = 1./Agrif_Mygrid % spaceref(i) 
    765         Agrif_Mygrid % Agrif_dt(i) = 1./Agrif_Mygrid % timeref(i) 
    766 !       Borders of the root coarse grid 
    767         Agrif_Mygrid % NearRootBorder(i) = .true. 
    768         Agrif_Mygrid % DistantRootBorder(i) = .true. 
    769     enddo 
    770 ! 
    771 !   The root coarse grid is a fixed grid 
    772     Agrif_Mygrid % fixed = .TRUE. 
    773 !   Level of the root grid 
    774     Agrif_Mygrid % level = 0 
    775 !   Maximum level in the hierarchy 
    776     Agrif_MaxLevelLoc = 0 
    777 ! 
    778 !   Number of the grid pointed by Agrif_Mygrid (root coarse grid) 
    779     Agrif_Mygrid % rank = 1 
    780 ! 
    781 !   Number of the root grid as a fixed grid 
    782     Agrif_Mygrid % fixedrank = 0 
    783 ! 
    784 !   Initialization of some fields of the root grid variables 
    785     ierr_allocate = 0 
    786     if( Agrif_NbVariables(0) > 0 ) allocate(Agrif_Mygrid % tabvars(Agrif_NbVariables(0)),stat=ierr_allocate) 
    787     if( Agrif_NbVariables(1) > 0 ) allocate(Agrif_Mygrid % tabvars_c(Agrif_NbVariables(1)),stat=ierr_allocate) 
    788     if( Agrif_NbVariables(2) > 0 ) allocate(Agrif_Mygrid % tabvars_r(Agrif_NbVariables(2)),stat=ierr_allocate) 
    789     if( Agrif_NbVariables(3) > 0 ) allocate(Agrif_Mygrid % tabvars_l(Agrif_NbVariables(3)),stat=ierr_allocate) 
    790     if( Agrif_NbVariables(4) > 0 ) allocate(Agrif_Mygrid % tabvars_i(Agrif_NbVariables(4)),stat=ierr_allocate) 
    791     if (ierr_allocate /= 0) THEN 
    792       STOP "*** ERROR WHEN ALLOCATING TABVARS ***" 
    793     endif 
    794 ! 
    795 !   Initialization of the other fields of the root grid variables (number of 
    796 !   cells, positions, number and type of its dimensions, ...) 
    797     call Agrif_Instance(Agrif_Mygrid) 
    798     call Agrif_Set_numberofcells(Agrif_Mygrid) 
    799 ! 
    800 !   Allocation of the array containing the values of the grid variables 
    801     call Agrif_Allocation(Agrif_Mygrid, procname2) 
    802     call Agrif_initialisations(Agrif_Mygrid) 
    803 ! 
    804 !   Total number of fixed grids 
    805     Agrif_nbfixedgrids = 0 
    806      
    807 ! If a grand mother grid is declared 
    808  
    809     if (agrif_coarse) then 
    810       allocate(Agrif_Coarsegrid) 
    811  
    812       Agrif_Coarsegrid % ngridstep = 0 
    813       Agrif_Coarsegrid % grid_id   = -9999 
    814        
    815     do i = 1, Agrif_Probdim 
    816         Agrif_Coarsegrid%spaceref(i) = coarse_spaceref(i) 
    817         Agrif_Coarsegrid%timeref(i) = coarse_timeref(i) 
    818         Agrif_Coarsegrid % ix(i) = 1 
    819         Agrif_Coarsegrid % Agrif_x(i)  = 0. 
    820         Agrif_Coarsegrid % Agrif_dx(i) = 1. 
    821         Agrif_Coarsegrid % Agrif_dt(i) = 1. 
    822 !       Borders of the root coarse grid 
    823         Agrif_Coarsegrid % NearRootBorder(i) = .true. 
    824         Agrif_Coarsegrid % DistantRootBorder(i) = .true. 
    825         Agrif_Coarsegrid % nb(i) =Agrif_mygrid%nb(i) / coarse_spaceref(i) 
    826     enddo       
    827  
    828 !   The root coarse grid is a fixed grid 
    829     Agrif_Coarsegrid % fixed = .TRUE. 
    830 !   Level of the root grid 
    831     Agrif_Coarsegrid % level = -1 
    832      
    833     Agrif_Coarsegrid % grand_mother_grid = .true. 
    834  
    835 !   Number of the grid pointed by Agrif_Mygrid (root coarse grid) 
    836     Agrif_Coarsegrid % rank = -9999 
    837 ! 
    838 !   Number of the root grid as a fixed grid 
    839     Agrif_Coarsegrid % fixedrank = -9999 
    840      
    841       Agrif_Mygrid%parent => Agrif_Coarsegrid 
    842        
    843 ! Not used but required to prevent seg fault 
    844       Agrif_Coarsegrid%parent => Agrif_Mygrid 
    845        
    846       call Agrif_Create_Var(Agrif_Coarsegrid) 
    847  
    848 ! Reset to null 
    849       Nullify(Agrif_Coarsegrid%parent) 
    850        
    851       Agrif_Coarsegrid%child_list%nitems = 1 
    852       allocate(Agrif_Coarsegrid%child_list%first) 
    853       allocate(Agrif_Coarsegrid%child_list%last) 
    854       Agrif_Coarsegrid%child_list%first%gr => Agrif_Mygrid 
    855       Agrif_Coarsegrid%child_list%last%gr => Agrif_Mygrid 
    856  
    857     endif 
    858      
    859     return 
    860  
    861 98  INQUIRE(FILE='AGRIF_FixedGrids.in',EXIST=BEXIST) 
    862     if (.not. BEXIST) then 
    863         print*,'ERROR : File AGRIF_FixedGrids.in not found.' 
    864         STOP 
    865     else 
    866         print*,'Error opening file AGRIF_FixedGrids.in' 
    867         STOP 
    868     endif 
    869      
    870 !--------------------------------------------------------------------------------------------------- 
    871 end subroutine Agrif_Init_Grids 
    872 !=================================================================================================== 
    873 ! 
    874 !=================================================================================================== 
    875 !  subroutine Agrif_Deallocation 
    876 ! 
    877 !> Deallocates all data arrays. 
    878 !--------------------------------------------------------------------------------------------------- 
    879 subroutine Agrif_Deallocation 
    880 !--------------------------------------------------------------------------------------------------- 
    881     integer                         :: nb 
    882     type(Agrif_Variable), pointer   :: var 
    883     type(Agrif_Variable_c), pointer   :: var_c 
    884     type(Agrif_Variable_l), pointer   :: var_l 
    885     type(Agrif_Variable_i), pointer   :: var_i 
    886 ! 
    887     do nb = 1,Agrif_NbVariables(0) 
    888 ! 
    889         var => Agrif_Mygrid % tabvars(nb) 
    890 ! 
    891         if ( allocated(var % array1) ) deallocate(var % array1) 
    892         if ( allocated(var % array2) ) deallocate(var % array2) 
    893         if ( allocated(var % array3) ) deallocate(var % array3) 
    894         if ( allocated(var % array4) ) deallocate(var % array4) 
    895         if ( allocated(var % array5) ) deallocate(var % array5) 
    896         if ( allocated(var % array6) ) deallocate(var % array6) 
    897 ! 
    898         if ( allocated(var % sarray1) ) deallocate(var % sarray1) 
    899         if ( allocated(var % sarray2) ) deallocate(var % sarray2) 
    900         if ( allocated(var % sarray3) ) deallocate(var % sarray3) 
    901         if ( allocated(var % sarray4) ) deallocate(var % sarray4) 
    902         if ( allocated(var % sarray5) ) deallocate(var % sarray5) 
    903         if ( allocated(var % sarray6) ) deallocate(var % sarray6) 
    904 ! 
    905         if ( allocated(var % darray1) ) deallocate(var % darray1) 
    906         if ( allocated(var % darray2) ) deallocate(var % darray2) 
    907         if ( allocated(var % darray3) ) deallocate(var % darray3) 
    908         if ( allocated(var % darray4) ) deallocate(var % darray4) 
    909         if ( allocated(var % darray5) ) deallocate(var % darray5) 
    910         if ( allocated(var % darray6) ) deallocate(var % darray6) 
    911 ! 
    912     enddo 
    913 ! 
    914     do nb = 1,Agrif_NbVariables(1) 
    915 ! 
    916         var_c => Agrif_Mygrid % tabvars_c(nb) 
    917 ! 
    918         if ( allocated(var_c % carray1) ) deallocate(var_c % carray1) 
    919         if ( allocated(var_c % carray2) ) deallocate(var_c % carray2) 
    920 ! 
    921     enddo 
    922  
    923     do nb = 1,Agrif_NbVariables(3) 
    924 ! 
    925         var_l => Agrif_Mygrid % tabvars_l(nb) 
    926 ! 
    927         if ( allocated(var_l % larray1) ) deallocate(var_l % larray1) 
    928         if ( allocated(var_l % larray2) ) deallocate(var_l % larray2) 
    929         if ( allocated(var_l % larray3) ) deallocate(var_l % larray3) 
    930         if ( allocated(var_l % larray4) ) deallocate(var_l % larray4) 
    931         if ( allocated(var_l % larray5) ) deallocate(var_l % larray5) 
    932         if ( allocated(var_l % larray6) ) deallocate(var_l % larray6) 
    933 ! 
    934     enddo 
    935 ! 
    936     do nb = 1,Agrif_NbVariables(4) 
    937 ! 
    938         var_i => Agrif_Mygrid % tabvars_i(nb) 
    939 ! 
    940         if ( allocated(var_i % iarray1) ) deallocate(var_i % iarray1) 
    941         if ( allocated(var_i % iarray2) ) deallocate(var_i % iarray2) 
    942         if ( allocated(var_i % iarray3) ) deallocate(var_i % iarray3) 
    943         if ( allocated(var_i % iarray4) ) deallocate(var_i % iarray4) 
    944         if ( allocated(var_i % iarray5) ) deallocate(var_i % iarray5) 
    945         if ( allocated(var_i % iarray6) ) deallocate(var_i % iarray6) 
    946 ! 
    947     enddo 
    948 ! 
    949     if ( allocated(Agrif_Mygrid % tabvars) )   deallocate(Agrif_Mygrid % tabvars) 
    950     if ( allocated(Agrif_Mygrid % tabvars_c) ) deallocate(Agrif_Mygrid % tabvars_c) 
    951     if ( allocated(Agrif_Mygrid % tabvars_r) ) deallocate(Agrif_Mygrid % tabvars_r) 
    952     if ( allocated(Agrif_Mygrid % tabvars_l) ) deallocate(Agrif_Mygrid % tabvars_l) 
    953     if ( allocated(Agrif_Mygrid % tabvars_i) ) deallocate(Agrif_Mygrid % tabvars_i) 
    954     deallocate(Agrif_Mygrid) 
    955 !--------------------------------------------------------------------------------------------------- 
    956 end subroutine Agrif_Deallocation 
    957 !=================================================================================================== 
    958 ! 
    959 !=================================================================================================== 
    960 !  subroutine Agrif_Step_adj 
    961 ! 
    962 !> creates the grid hierarchy and manages the backward time integration procedure. 
    963 !> It is called in the main program. 
    964 !> calls subroutines #Agrif_Regrid and #Agrif_Integrate_adj. 
    965 !--------------------------------------------------------------------------------------------------- 
    966 subroutine Agrif_Step_adj ( procname ) 
    967 !--------------------------------------------------------------------------------------------------- 
    968     procedure(step_proc)    :: procname     !< Subroutine to call on each grid