Changeset 13027


Ignore:
Timestamp:
2020-06-03T16:36:09+02:00 (20 months ago)
Author:
rblod
Message:

New AGRIF library, see ticket #2129

Location:
vendors/AGRIF/dev_r12970_AGRIF_CMEMS
Files:
1 added
32 edited

Legend:

Unmodified
Added
Removed

  • vendors/AGRIF/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modarrays.F90

    r5656 r13027  
    5555                               proc_id,         & 
    5656                               coords,          & 
    57                                lb_tab_true, ub_tab_true, memberin ) 
     57                               lb_tab_true, ub_tab_true, memberin,  & 
     58                               indminglob3,indmaxglob3,check_perio) 
    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 
    … …  
    6769    integer, dimension(nbdim), intent(out) :: ub_tab_true   !< Global value of ub_var on the current processor 
    6870    logical,                   intent(out) :: memberin 
     71    logical,optional,          intent(in)  :: check_perio   !< check for periodicity 
     72    logical :: check_perio_local 
    6973! 
    7074    integer :: i, coord_i 
    7175    integer :: lb_glob_index, ub_glob_index ! Lower and upper global indices 
     76     
     77    if (present(check_perio)) then 
     78       check_perio_local=check_perio 
     79    else 
     80       check_perio_local = .FALSE. 
     81    endif 
    7282! 
    7383    do i = 1, nbdim 
    … …  
    7888        call Agrif_InvLoc( lb_var(i), proc_id, coord_i, lb_glob_index ) 
    7989        call Agrif_InvLoc( ub_var(i), proc_id, coord_i, ub_glob_index ) 
     90        if (agrif_debug_interp .or. agrif_debug_update) then 
     91        print *,'direction ',i,' lblogb ubglob = ',lb_glob_index,ub_glob_index 
     92        endif 
     93        if (check_perio_local .AND. agrif_curgrid%periodicity(i)) then 
     94          if (lb_tab(i)>=lb_glob_index) then 
     95          else if (lb_tab(i)<ub_glob_index-agrif_curgrid%periodicity_decal(i)) then 
     96            lb_glob_index = lb_glob_index - agrif_curgrid%periodicity_decal(i) 
     97            ub_glob_index = ub_glob_index - agrif_curgrid%periodicity_decal(i) 
     98          endif 
     99        endif 
     100         
     101        if (present(indminglob3)) then 
     102          indminglob3(i)=lb_glob_index 
     103          indmaxglob3(i)=ub_glob_index 
     104        endif 
    80105#else 
    81106        lb_glob_index = lb_var(i) 
     107        if (check_perio_local .AND. agrif_curgrid%periodicity(i)) then 
     108          lb_glob_index = lb_tab(i) 
     109        endif 
    82110        ub_glob_index = ub_var(i) 
    83111#endif 
    84112        lb_tab_true(i) = max(lb_tab(i), lb_glob_index) 
    85113        ub_tab_true(i) = min(ub_tab(i), ub_glob_index) 
     114        if (agrif_debug_interp .or. agrif_debug_update) then 
     115        print *,'childbounds = ',i,lb_tab(i),lb_glob_index,lb_tab_true(i), & 
     116        ub_tab(i),ub_glob_index,ub_tab_true(i) 
     117        endif 
    86118    enddo 
    87119! 
    … …  
    93125        endif 
    94126    enddo 
     127    if (agrif_debug_interp) then 
     128    print *,'memberin = ',memberin 
     129    endif 
    95130!--------------------------------------------------------------------------------------------------- 
    96131end subroutine Agrif_Childbounds 
    … …  
    123158! 
    124159    iminmaxg(1:nbdim,2) = - iminmaxg(1:nbdim,2) 
    125     call MPI_ALLREDUCE(iminmaxg, lubglob, 2*nbdim, MPI_INTEGER, MPI_MIN, Agrif_mpi_comm, code) 
     160    call MPI_ALLREDUCE(iminmaxg, lubglob, 2*nbdim, MPI_INTEGER, MPI_MIN, & 
     161                       Agrif_mpi_comm, code) 
    126162    lubglob(1:nbdim,2)  = - lubglob(1:nbdim,2) 
    127163#endif 
    … …  
    659695        case('x') 
    660696! 
    661             lb_child(n)  = root_var % point(n) 
    662             lb_parent(n) = root_var % point(n) 
     697            lb_child(n)  = child%point(n) 
     698            lb_parent(n) = child%parent_var%point(n) 
    663699            nb_child(n)  = Agrif_Child_Gr % nb(1) 
    664700            s_child(n)   = Agrif_Child_Gr  % Agrif_x(1) 
    … …  
    666702            ds_child(n)  = Agrif_Child_Gr  % Agrif_dx(1) 
    667703            ds_parent(n) = Agrif_Parent_Gr % Agrif_dx(1) 
     704            ! Take into account potential difference of first points 
     705            s_parent(n) = s_parent(n) + (lb_parent(n)-lb_child(n))*ds_parent(n) 
    668706! 
    669707            if ( root_var % posvar(n) == 1 ) then 
    … …  
    677715        case('y') 
    678716! 
    679             lb_child(n)  = root_var % point(n) 
    680             lb_parent(n) = root_var % point(n) 
     717            lb_child(n)  = child%point(n) 
     718            lb_parent(n) = child%parent_var%point(n) 
    681719            nb_child(n)  = Agrif_Child_Gr % nb(2) 
    682720            s_child(n)   = Agrif_Child_Gr  % Agrif_x(2) 
    … …  
    684722            ds_child(n)  = Agrif_Child_Gr  % Agrif_dx(2) 
    685723            ds_parent(n) = Agrif_Parent_Gr % Agrif_dx(2) 
     724            ! Take into account potential difference of first points 
     725            s_parent(n) = s_parent(n) + (lb_parent(n)-lb_child(n))*ds_parent(n) 
    686726! 
    687727            if (root_var % posvar(n)==1) then 
    … …  
    695735        case('z') 
    696736! 
    697             lb_child(n)  = root_var % point(n) 
    698             lb_parent(n) = root_var % point(n) 
     737            lb_child(n)  = child%point(n) 
     738            lb_parent(n) = child%parent_var%point(n) 
    699739            nb_child(n)  = Agrif_Child_Gr % nb(3) 
    700740            s_child(n)   = Agrif_Child_Gr  % Agrif_x(3) 
    … …  
    702742            ds_child(n)  = Agrif_Child_Gr  % Agrif_dx(3) 
    703743            ds_parent(n) = Agrif_Parent_Gr % Agrif_dx(3) 
     744            ! Take into account potential difference of first points 
     745            s_parent(n) = s_parent(n) + (lb_parent(n)-lb_child(n))*ds_parent(n) 
    704746! 
    705747            if (root_var % posvar(n)==1) then 
    … …  
    781823!--------------------------------------------------------------------------------------------------- 
    782824subroutine Agrif_GlobalToLocalBounds ( locbounds, lb_var, ub_var, lb_glob, ub_glob,    & 
    783                                        coords, nbdim, rank, member ) 
     825                                       coords, nbdim, rank, member,check_perio ) 
    784826!--------------------------------------------------------------------------------------------------- 
    785827    integer, dimension(nbdim,2,2), intent(out)   :: locbounds   !< Local values of \b lb_glob and \b ub_glob 
    … …  
    792834    integer,                       intent(in)    :: rank        !< Rank of the processor 
    793835    logical,                       intent(out)   :: member 
    794 ! 
    795     integer     :: i, i1, k 
     836    logical,optional,          intent(in)  :: check_perio   !< check for periodicity 
     837    logical :: check_perio_local 
     838! 
     839    integer     :: i, i1, k, idecal 
    796840    integer     :: nbloc(nbdim) 
     841     
     842    if (present(check_perio)) then 
     843       check_perio_local=check_perio 
     844    else 
     845       check_perio_local = .FALSE. 
     846    endif 
     847! 
     848 
    797849! 
    798850    locbounds(:,1,:) =  HUGE(1) 
    … …  
    803855    do i = 1,nbdim 
    804856! 
     857     if (coords(i) == 0) then 
     858       nbloc(i) = 1 
     859       locbounds(i,1,1) = lb_glob(i) 
     860       locbounds(i,2,1) = ub_glob(i) 
     861       locbounds(i,1,2) = lb_glob(i) 
     862       locbounds(i,2,2) = ub_glob(i) 
     863     else 
    805864        call Agrif_InvLoc(lb_var(i), rank, coords(i), i1) 
     865        if ((i1>ub_glob(i)).AND.check_perio_local) then 
     866          idecal = agrif_curgrid%periodicity_decal(i) 
     867        else 
     868          idecal = 0 
     869        endif 
    806870! 
    807871        do k = lb_glob(i)+lb_var(i)-i1,ub_glob(i)+lb_var(i)-i1 
    808872! 
    809             if ( (k >= lb_var(i)) .AND. (k <= ub_var(i)) ) then 
     873            if ( (k + idecal >= lb_var(i)) .AND. (k + idecal <= ub_var(i)) ) then 
     874!            if ((k<=ub_var(i)).AND.((k>=lb_var(i).OR.check_perio_local))) then 
    810875                nbloc(i) = 1 
    811876                locbounds(i,1,1) = min(locbounds(i,1,1),k-lb_var(i)+i1) 
    812877                locbounds(i,2,1) = max(locbounds(i,2,1),k-lb_var(i)+i1) 
    813878 
    814                 locbounds(i,1,2) = min(locbounds(i,1,2),k) 
    815                 locbounds(i,2,2) = max(locbounds(i,2,2),k) 
    816             endif 
    817         enddo 
     879                locbounds(i,1,2) = min(locbounds(i,1,2),k + idecal) 
     880                locbounds(i,2,2) = max(locbounds(i,2,2),k + idecal) 
     881            endif 
     882        enddo 
     883     endif 
    818884    enddo 
    819885 

  • vendors/AGRIF/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modbc.F90

    r5656 r13027  
    7373    Agrif_Parent_Gr => Agrif_Curgrid % parent 
    7474! 
    75     loctab_child(:) = 0 
     75    loctab_child(1:nbdim) = 0 
    7676    posvartab_child(1:nbdim) = root_var % posvar(1:nbdim) 
    7777! 

  • vendors/AGRIF/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modbcfunction.F90

    r5656 r13027  
    5353!> To set the TYPE of the variable 
    5454!--------------------------------------------------------------------------------------------------- 
    55 subroutine Agrif_Set_parent_int(tabvarsindic,value) 
    56 !--------------------------------------------------------------------------------------------------- 
    57     integer, intent(in)     :: tabvarsindic !< indice of the variable in tabvars 
     55subroutine Agrif_Set_parent_int(integer_variable,value) 
     56!--------------------------------------------------------------------------------------------------- 
     57    integer, intent(in)     :: integer_variable !< indice of the variable in tabvars 
    5858    integer, intent(in)     :: value        !< input value 
    5959! 
    60     Agrif_Curgrid % parent % tabvars_i(tabvarsindic) % iarray0 = value 
     60     
     61integer :: i 
     62logical :: i_found 
     63 
     64i_found = .FALSE. 
     65 
     66do i=1,Agrif_NbVariables(4) 
     67  if (LOC(integer_variable) == LOC(agrif_curgrid%tabvars_i(i)%iarray0)) then 
     68     agrif_curgrid%tabvars_i(i)%parent_var%iarray0 = value 
     69     i_found = .TRUE. 
     70     EXIT 
     71  endif 
     72enddo 
     73 
     74if (.NOT.i_found) STOP 'Agrif_Set_Integer : Variable not found' 
     75 
    6176!--------------------------------------------------------------------------------------------------- 
    6277end subroutine Agrif_Set_parent_int 
    … …  
    6681!  subroutine Agrif_Set_parent_real4 
    6782!--------------------------------------------------------------------------------------------------- 
    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 
     83!> To set the parent value of a real variable 
     84!--------------------------------------------------------------------------------------------------- 
     85subroutine Agrif_Set_parent_real4 ( real_variable, value ) 
     86!--------------------------------------------------------------------------------------------------- 
     87    real(kind=4), intent(in)     :: real_variable !< input variable 
     88    real(kind=4),intent(in) :: value        !< input value for the parent grid 
     89 
     90integer :: i 
     91logical :: i_found 
     92 
     93i_found = .FALSE. 
     94 
     95do i=1,Agrif_NbVariables(2) 
     96  if (LOC(real_variable) == LOC(agrif_curgrid%tabvars_r(i)%array0)) then 
     97     agrif_curgrid%tabvars_r(i)%parent_var%array0 = value 
     98     agrif_curgrid%tabvars_r(i)%parent_var%sarray0 = value 
     99     i_found = .TRUE. 
     100     EXIT 
     101  endif 
     102enddo 
     103 
     104IF (.NOT.i_found) THEN 
     105do i=1,Agrif_NbVariables(2) 
     106  if (LOC(real_variable) == LOC(agrif_curgrid%tabvars_r(i)%sarray0)) then 
     107     agrif_curgrid%tabvars_r(i)%parent_var%array0 = value 
     108     agrif_curgrid%tabvars_r(i)%parent_var%sarray0 = value 
     109     i_found = .TRUE. 
     110     EXIT 
     111  endif 
     112enddo 
     113ENDIF 
     114 
     115if (.NOT.i_found) STOP 'Agrif_Set_parent_real4 : Variable not found' 
     116 
    77117!--------------------------------------------------------------------------------------------------- 
    78118end subroutine Agrif_Set_parent_real4 
    … …  
    82122!  subroutine Agrif_Set_parent_real8 
    83123!--------------------------------------------------------------------------------------------------- 
    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 
     124!> To set the parent value of a real variable 
     125!--------------------------------------------------------------------------------------------------- 
     126subroutine Agrif_Set_parent_real8 ( real_variable, value ) 
     127!--------------------------------------------------------------------------------------------------- 
     128    real(kind=8), intent(in)     :: real_variable !< input variable 
     129    real(kind=8),intent(in) :: value        !< input value for the parent grid 
     130 
     131integer :: i 
     132logical :: i_found 
     133 
     134i_found = .FALSE. 
     135 
     136do i=1,Agrif_NbVariables(2) 
     137  if (LOC(real_variable) == LOC(agrif_curgrid%tabvars_r(i)%array0)) then 
     138     agrif_curgrid%tabvars_r(i)%parent_var%darray0 = value 
     139     agrif_curgrid%tabvars_r(i)%parent_var%array0 = value 
     140     i_found = .TRUE. 
     141     EXIT 
     142  endif 
     143enddo 
     144 
     145IF (.NOT.i_found) THEN 
     146do i=1,Agrif_NbVariables(2) 
     147  if (LOC(real_variable) == LOC(agrif_curgrid%tabvars_r(i)%darray0)) then 
     148     agrif_curgrid%tabvars_r(i)%parent_var%darray0 = value 
     149     agrif_curgrid%tabvars_r(i)%parent_var%array0 = value 
     150     i_found = .TRUE. 
     151     EXIT 
     152  endif 
     153enddo 
     154ENDIF 
     155 
     156if (.NOT.i_found) STOP 'Agrif_Set_parent_real8 : Variable not found' 
     157 
    92158!--------------------------------------------------------------------------------------------------- 
    93159end subroutine Agrif_Set_parent_real8 
    … …  
    106172    type(Agrif_Variable),  pointer  :: var 
    107173! 
    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  
     174    var => Agrif_Search_Variable(Agrif_Curgrid,tabvarsindic) 
    117175    if (.not.associated(var)) return ! Grand mother grid case 
    118176! 
    … …  
    145203    type(Agrif_Variable), pointer   :: var 
    146204! 
    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 
     205    var => Agrif_Search_Variable(Agrif_Curgrid,tabvarsindic) 
     206    if (.not.associated(var)) return ! Grand mother grid case 
    155207! 
    156208    var % type_interp = Agrif_Constant 
    … …  
    178230    TYPE(Agrif_Variable), pointer   :: var 
    179231! 
    180     indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0 
    181 ! 
    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 
     232    var => Agrif_Search_Variable(Agrif_Curgrid,tabvarsindic) 
    188233! 
    189234    var % type_interp_bc = Agrif_Constant 
    … …  
    214259    type(Agrif_Variable),  pointer  :: root_var 
    215260! 
    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 
     261 
     262        root_var => Agrif_Search_Variable(Agrif_Mygrid,tabvarsindic) 
     263 
    224264! 
    225265    root_var % type_update = Agrif_Update_Copy 
    … …  
    243283    INTEGER :: indic  !  indice of the variable in tabvars 
    244284! 
     285print *,'CURRENTLY BROKEN' 
     286STOP 
     287 
    245288    indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0 
    246289! 
    … …  
    283326    type(Agrif_Variable), pointer :: child_var 
    284327    type(Agrif_Variable), pointer :: child_tmp      ! Temporary variable on the child grid 
     328    integer :: i 
     329    integer,dimension(7) :: lb, ub 
    285330! 
    286331    if ( Agrif_Curgrid%level <= 0 ) return 
    287332! 
    288     indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0 
    289333! 
    290334    if ( present(calledweight) ) then 
    … …  
    296340    endif 
    297341! 
    298     if (indic <= 0) then 
    299         child_var  => Agrif_Search_Variable(Agrif_Curgrid,-indic) 
     342        child_var  => Agrif_Search_Variable(Agrif_Curgrid,tabvarsindic) 
    300343        parent_var => child_var % parent_var 
    301344        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 
    308345! 
    309346    nbdim = root_var % nbdim 
    310347! 
     348    do i=1,nbdim 
     349      if (root_var%coords(i) == 0) then 
     350        lb(i) = parent_var%lb(i) 
     351        ub(i) = parent_var%ub(i) 
     352      else 
     353        lb(i) = child_var%lb(i) 
     354        ub(i) = child_var%ub(i) 
     355      endif 
     356    enddo 
     357 
    311358    select case( nbdim ) 
    312359    case(1) 
    313         allocate(parray1(child_var%lb(1):child_var%ub(1))) 
     360        allocate(parray1(lb(1):ub(1))) 
    314361    case(2) 
    315         allocate(parray2(child_var%lb(1):child_var%ub(1), & 
    316                          child_var%lb(2):child_var%ub(2) )) 
     362        allocate(parray2(lb(1):ub(1), & 
     363                         lb(2):ub(2) )) 
    317364    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) )) 
     365        allocate(parray3(lb(1):ub(1), & 
     366                         lb(2):ub(2), & 
     367                         lb(3):ub(3) )) 
    321368    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) )) 
     369        allocate(parray4(lb(1):ub(1), & 
     370                         lb(2):ub(2), & 
     371                         lb(3):ub(3), & 
     372                         lb(4):ub(4) )) 
    326373    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) )) 
     374        allocate(parray5(lb(1):ub(1), & 
     375                         lb(2):ub(2), & 
     376                         lb(3):ub(3), & 
     377                         lb(4):ub(4), & 
     378                         lb(5):ub(5) )) 
    332379    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) )) 
     380        allocate(parray6(lb(1):ub(1), & 
     381                         lb(2):ub(2), & 
     382                         lb(3):ub(3), & 
     383                         lb(4):ub(4), & 
     384                         lb(5):ub(5), & 
     385                         lb(6):ub(6) )) 
    339386    end select 
    340387! 
    … …  
    343390! 
    344391    child_tmp % root_var => root_var 
     392    child_tmp % parent_var => parent_var 
    345393    child_tmp % oldvalues2D => child_var % oldvalues2D 
    346394! 
    … …  
    400448    type(Agrif_Variable), pointer   :: child_tmp        ! Temporary variable on the child grid 
    401449! 
     450 
    402451    if ( Agrif_Curgrid%level <= 0 ) return 
    403452! 
    404     indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0 
    405 ! 
    406     if (indic <= 0) then 
    407         child_var  => Agrif_Search_Variable(Agrif_Curgrid,-indic) 
     453 
     454        child_var  => Agrif_Search_Variable(Agrif_Curgrid,tabvarsindic) 
    408455        parent_var => child_var % parent_var 
    409456        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 
     457 
    416458! 
    417459    nbdim     = root_var % nbdim 
    … …  
    421463! 
    422464    child_tmp % root_var => root_var 
     465    child_tmp % parent_var => parent_var 
    423466    child_tmp % nbdim = root_var % nbdim 
    424467    child_tmp % point = child_var % point 
    … …  
    486529    if (agrif_curgrid%grand_mother_grid) return 
    487530! 
    488     indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0 
    489 ! 
    490     if (indic <= 0) then 
    491         child_var  => Agrif_Search_Variable(Agrif_Curgrid, -indic) 
     531 
     532        child_var  => Agrif_Search_Variable(Agrif_Curgrid, tabvarsindic) 
    492533        parent_var => child_var % parent_var 
    493534 
    494535        if (.not.associated(parent_var)) then 
    495536          ! can occur during the first update of Agrif_Coarsegrid (if any) 
    496           parent_var => Agrif_Search_Variable(Agrif_Curgrid % parent, -indic) 
     537          parent_var => Agrif_Search_Variable(Agrif_Curgrid % parent, tabvarsindic) 
    497538          child_var % parent_var => parent_var 
    498539        endif 
    499540 
    500541        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 
     542 
    507543! 
    508544    nbdim = root_var % nbdim 
    … …  
    551587    integer :: nbdim 
    552588! 
     589print *,'CURRENTLY BROKEN' 
     590STOP 
    553591    root_var => Agrif_Mygrid % tabvars(tabvarsindic0) 
    554592    save_var => Agrif_Curgrid % tabvars(tabvarsindic0) 
    … …  
    575613    integer                         :: indic 
    576614! 
     615print *,'CURRENTLY BROKEN' 
     616STOP 
    577617    indic = tabvarsindic 
    578618    if (tabvarsindic >= 0) then 
    … …  
    612652    integer                         :: indic 
    613653! 
     654print *,'CURRENTLY BROKEN' 
     655STOP 
     656 
    614657    indic = tabvarsindic 
    615658    if (tabvarsindic >= 0) then 
    … …  
    650693    integer                         :: indic 
    651694! 
     695print *,'CURRENTLY BROKEN' 
     696STOP 
    652697    indic = tabvarsindic 
    653698    if (tabvarsindic >= 0) then 

  • vendors/AGRIF/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modcurgridfunctions.F90

    r5656 r13027  
    2929    implicit none 
    3030! 
     31 
     32    interface Agrif_Parent 
     33        module procedure Agrif_Parent_Real_4,   & 
     34                         Agrif_Parent_Real_8,   & 
     35                         Agrif_Parent_Array2_Real_8,   & 
     36                         Agrif_Parent_Integer, & 
     37                         Agrif_Parent_Character, & 
     38                         Agrif_Parent_Logical 
     39    end interface 
     40    interface Agrif_Child 
     41        module procedure Agrif_Child_Logical 
     42    end interface 
     43     
    3144contains 
    3245! 
    … …  
    657670end subroutine Agrif_Set_coeffreft_z 
    658671!=================================================================================================== 
     672!  subroutine Agrif_Set_coeffreft 
     673!--------------------------------------------------------------------------------------------------- 
     674subroutine Agrif_Set_coeffreft ( coeffref ) 
     675!--------------------------------------------------------------------------------------------------- 
     676    integer, intent(in) :: coeffref 
     677    integer :: i 
     678 
     679    if (coeffref < 0) then 
     680        write(*,*)'Coefficient of time raffinement should be positive' 
     681        stop 
     682    else 
     683        do i=1,Agrif_Probdim 
     684          Agrif_coeffreft(i) = coeffref 
     685          Agrif_Curgrid % timeref(i) = coeffref 
     686        enddo 
     687    endif 
     688!--------------------------------------------------------------------------------------------------- 
     689end subroutine Agrif_Set_coeffreft 
     690!=================================================================================================== 
    659691! 
    660692!=================================================================================================== 
    … …  
    738770end function Agrif_Level 
    739771!=================================================================================================== 
     772!=================================================================================================== 
     773!  subroutine Agrif_set_periodicity 
     774!--------------------------------------------------------------------------------------------------- 
     775 
     776subroutine Agrif_set_periodicity(i,decal) 
     777!--------------------------------------------------------------------------------------------------- 
     778    integer :: i, decal 
     779     
     780    Agrif_curgrid%periodicity(i)=.TRUE. 
     781    Agrif_curgrid%periodicity_decal(i)=decal 
     782     
     783!--------------------------------------------------------------------------------------------------- 
     784end subroutine Agrif_set_periodicity 
    740785! 
    741786!=================================================================================================== 
    … …  
    763808!=================================================================================================== 
    764809! 
     810 
     811function Agrif_Parent_Real_4(real_variable) result(real_variable_parent) 
     812real(KIND=4) :: real_variable 
     813real(KIND=4) :: real_variable_parent 
     814 
     815integer :: i 
     816logical :: i_found 
     817 
     818i_found = .FALSE. 
     819 
     820do i=1,Agrif_NbVariables(2) 
     821  if (LOC(real_variable) == LOC(agrif_curgrid%tabvars_r(i)%array0)) then 
     822     real_variable_parent = agrif_curgrid%tabvars_r(i)%parent_var%array0 
     823     i_found = .TRUE. 
     824     EXIT 
     825  endif 
     826enddo 
     827 
     828IF (.NOT.i_found) THEN 
     829do i=1,Agrif_NbVariables(2) 
     830  if (LOC(real_variable) == LOC(agrif_curgrid%tabvars_r(i)%sarray0)) then 
     831     real_variable_parent = agrif_curgrid%tabvars_r(i)%parent_var%sarray0 
     832     i_found = .TRUE. 
     833     EXIT 
     834  endif 
     835enddo 
     836ENDIF 
     837 
     838if (.NOT.i_found) STOP 'Agrif_Parent_Real_4 : Variable not found' 
     839 
     840end function Agrif_Parent_Real_4 
     841 
     842function Agrif_Parent_Real_8(real_variable) result(real_variable_parent) 
     843real(KIND=8) :: real_variable 
     844real(KIND=8) :: real_variable_parent 
     845 
     846integer :: i 
     847logical :: i_found 
     848 
     849i_found = .FALSE. 
     850 
     851do i=1,Agrif_NbVariables(2) 
     852  if (LOC(real_variable) == LOC(agrif_curgrid%tabvars_r(i)%array0)) then 
     853     real_variable_parent = agrif_curgrid%tabvars_r(i)%parent_var%array0 
     854     i_found = .TRUE. 
     855     EXIT 
     856  endif 
     857enddo 
     858 
     859IF (.NOT.i_found) THEN 
     860do i=1,Agrif_NbVariables(2) 
     861  if (LOC(real_variable) == LOC(agrif_curgrid%tabvars_r(i)%darray0)) then 
     862     real_variable_parent = agrif_curgrid%tabvars_r(i)%parent_var%darray0 
     863     i_found = .TRUE. 
     864     EXIT 
     865  endif 
     866enddo 
     867ENDIF 
     868 
     869if (.NOT.i_found) STOP 'Agrif_Parent_Real_8 : Variable not found' 
     870 
     871end function Agrif_Parent_Real_8 
     872 
     873function Agrif_Parent_Array2_Real_8(real_variable,ji,jj) result(real_variable_parent) 
     874real(KIND=8), DIMENSION(:,:) :: real_variable 
     875real(KIND=8) :: real_variable_parent 
     876integer :: ji,jj 
     877 
     878integer :: i 
     879logical :: i_found 
     880 
     881i_found = .FALSE. 
     882 
     883do i=1,Agrif_NbVariables(0) 
     884  if (LOC(real_variable) == LOC(agrif_curgrid%tabvars(i)%array2)) then 
     885     real_variable_parent = agrif_curgrid%tabvars(i)%parent_var%array2(ji,jj) 
     886     i_found = .TRUE. 
     887     EXIT 
     888  endif 
     889enddo 
     890 
     891if (.NOT.i_found) STOP 'Agrif_Parent_Array2_Real_8 : Variable not found' 
     892 
     893end function Agrif_Parent_Array2_Real_8 
     894 
     895 
     896function Agrif_Parent_Integer(integer_variable) result(integer_variable_parent) 
     897integer :: integer_variable 
     898integer :: integer_variable_parent 
     899 
     900integer :: i 
     901logical :: i_found 
     902 
     903i_found = .FALSE. 
     904 
     905do i=1,Agrif_NbVariables(4) 
     906  if (LOC(integer_variable) == LOC(agrif_curgrid%tabvars_i(i)%iarray0)) then 
     907     integer_variable_parent = agrif_curgrid%tabvars_i(i)%parent_var%iarray0 
     908     i_found = .TRUE. 
     909     EXIT 
     910  endif 
     911enddo 
     912 
     913if (.NOT.i_found) STOP 'Agrif_Parent : Variable not found' 
     914 
     915end function Agrif_Parent_Integer 
     916 
     917function Agrif_Parent_Character(character_variable) result(character_variable_parent) 
     918character(*) :: character_variable 
     919character(len(character_variable)) :: character_variable_parent 
     920 
     921integer :: i 
     922logical :: i_found 
     923 
     924i_found = .FALSE. 
     925 
     926do i=1,Agrif_NbVariables(1) 
     927  if (LOC(character_variable) == LOC(agrif_curgrid%tabvars_c(i)%carray0)) then 
     928     character_variable_parent = agrif_curgrid%tabvars_c(i)%parent_var%carray0 
     929     i_found = .TRUE. 
     930     EXIT 
     931  endif 
     932enddo 
     933 
     934if (.NOT.i_found) STOP 'Agrif_Parent : Variable not found' 
     935 
     936end function Agrif_Parent_Character 
     937 
     938function Agrif_Parent_Logical(logical_variable) result(logical_variable_parent) 
     939logical :: logical_variable 
     940logical :: logical_variable_parent 
     941 
     942integer :: i 
     943logical :: i_found 
     944 
     945i_found = .FALSE. 
     946 
     947do i=1,Agrif_NbVariables(3) 
     948  if (LOC(logical_variable) == LOC(agrif_curgrid%tabvars_l(i)%larray0)) then 
     949     logical_variable_parent = agrif_curgrid%tabvars_l(i)%parent_var%larray0 
     950     i_found = .TRUE. 
     951     EXIT 
     952  endif 
     953enddo 
     954 
     955if (.NOT.i_found) STOP 'Agrif_Parent : Variable not found' 
     956 
     957end function Agrif_Parent_Logical 
     958 
     959function Agrif_Child_Logical(logical_variable) result(logical_variable_child) 
     960logical :: logical_variable 
     961logical :: logical_variable_child 
     962 
     963integer :: i 
     964logical :: i_found 
     965 
     966i_found = .FALSE. 
     967 
     968do i=1,Agrif_NbVariables(3) 
     969  if (LOC(logical_variable) == LOC(agrif_curgrid%tabvars_l(i)%larray0)) then 
     970     logical_variable_child = Agrif_CurChildgrid%tabvars_l(i)%larray0 
     971     i_found = .TRUE. 
     972     EXIT 
     973  endif 
     974enddo 
     975 
     976if (.NOT.i_found) STOP 'Agrif_Child : Variable not found' 
     977 
     978end function Agrif_Child_Logical 
     979 
     980function Agrif_Irhox() result(i_val) 
     981integer :: i_val 
     982i_val = agrif_curgrid%spaceref(1) 
     983end function Agrif_Irhox 
     984 
     985function Agrif_Irhoy() result(i_val) 
     986integer :: i_val 
     987i_val = agrif_curgrid%spaceref(2) 
     988end function Agrif_Irhoy 
     989 
     990function Agrif_Irhoz() result(i_val) 
     991integer :: i_val 
     992i_val = agrif_curgrid%spaceref(3) 
     993end function Agrif_Irhoz 
     994 
     995function Agrif_NearCommonBorderX() result(l_val) 
     996logical :: l_val 
     997l_val = agrif_curgrid%nearRootBorder(1) 
     998end function Agrif_NearCommonBorderX 
     999 
     1000subroutine Agrif_Set_NearCommonBorderX(l_val) 
     1001logical,intent(in) :: l_val 
     1002agrif_curgrid%nearRootBorder(1)=l_val 
     1003end subroutine Agrif_Set_NearCommonBorderX 
     1004 
     1005function Agrif_NearCommonBorderY() result(l_val) 
     1006logical :: l_val 
     1007l_val = agrif_curgrid%nearRootBorder(2) 
     1008end function Agrif_NearCommonBorderY 
     1009 
     1010subroutine Agrif_Set_NearCommonBorderY(l_val) 
     1011logical,intent(in) :: l_val 
     1012agrif_curgrid%nearRootBorder(2)=l_val 
     1013end subroutine Agrif_Set_NearCommonBorderY 
     1014 
     1015function Agrif_NearCommonBorderZ() result(l_val) 
     1016logical :: l_val 
     1017l_val = agrif_curgrid%nearRootBorder(3) 
     1018end function Agrif_NearCommonBorderZ 
     1019 
     1020subroutine Agrif_Set_NearCommonBorderZ(l_val) 
     1021logical,intent(in) :: l_val 
     1022agrif_curgrid%nearRootBorder(3)=l_val 
     1023end subroutine Agrif_Set_NearCommonBorderZ 
     1024 
     1025function Agrif_DistantCommonBorderX() result(l_val) 
     1026logical :: l_val 
     1027l_val = agrif_curgrid%DistantRootBorder(1) 
     1028end function Agrif_DistantCommonBorderX 
     1029 
     1030subroutine Agrif_Set_DistantCommonBorderX(l_val) 
     1031logical,intent(in) :: l_val 
     1032agrif_curgrid%DistantRootBorder(1)=l_val 
     1033end subroutine Agrif_Set_DistantCommonBorderX 
     1034 
     1035function Agrif_DistantCommonBorderY() result(l_val) 
     1036logical :: l_val 
     1037l_val = agrif_curgrid%DistantRootBorder(2) 
     1038end function Agrif_DistantCommonBorderY 
     1039 
     1040subroutine Agrif_Set_DistantCommonBorderY(l_val) 
     1041logical,intent(in) :: l_val 
     1042agrif_curgrid%DistantRootBorder(2)=l_val 
     1043end subroutine Agrif_Set_DistantCommonBorderY 
     1044 
     1045function Agrif_DistantCommonBorderZ() result(l_val) 
     1046logical :: l_val 
     1047l_val = agrif_curgrid%DistantRootBorder(3) 
     1048end function Agrif_DistantCommonBorderZ 
     1049 
     1050subroutine Agrif_Set_DistantCommonBorderZ(l_val) 
     1051logical,intent(in) :: l_val 
     1052agrif_curgrid%DistantRootBorder(3)=l_val 
     1053end subroutine Agrif_Set_DistantCommonBorderZ 
     1054 
     1055function Agrif_Ix() result(i_val) 
     1056integer :: i_val 
     1057i_val = agrif_curgrid%ix(1) 
     1058end function Agrif_Ix 
     1059 
     1060function Agrif_Iy() result(i_val) 
     1061integer :: i_val 
     1062i_val = agrif_curgrid%ix(2) 
     1063end function Agrif_Iy 
     1064 
     1065function Agrif_Iz() result(i_val) 
     1066integer :: i_val 
     1067i_val = agrif_curgrid%ix(3) 
     1068end function Agrif_Iz 
     1069 
     1070function Agrif_Get_grid_id() result(i_val) 
     1071integer :: i_val 
     1072i_val = agrif_curgrid % grid_id 
     1073end function Agrif_Get_grid_id 
     1074 
     1075function Agrif_Get_parent_id() result(i_val) 
     1076integer :: i_val 
     1077i_val = agrif_curgrid % parent % grid_id 
     1078end function Agrif_Get_parent_id 
     1079 
     1080function Agrif_rhox() result(r_val) 
     1081real :: r_val 
     1082r_val = real(agrif_curgrid%spaceref(1)) 
     1083end function Agrif_rhox 
     1084 
     1085function Agrif_rhoy() result(r_val) 
     1086real :: r_val 
     1087r_val = real(agrif_curgrid%spaceref(2)) 
     1088end function Agrif_rhoy 
     1089 
     1090function Agrif_rhoz() result(r_val) 
     1091real :: r_val 
     1092r_val = real(agrif_curgrid%spaceref(3)) 
     1093end function Agrif_rhoz 
     1094 
     1095function Agrif_Nb_Step() result(i_val) 
     1096integer :: i_val 
     1097i_val = agrif_curgrid%ngridstep 
     1098end function Agrif_Nb_Step 
     1099 
     1100function Agrif_Nb_Fine_Grids() result(i_val) 
     1101integer :: i_val 
     1102i_val = Agrif_nbfixedgrids 
     1103end function Agrif_Nb_Fine_Grids 
     1104 
     1105! Set the name of the External mapping subroutine (if needed) 
     1106subroutine Agrif_Set_ExternalMapping(external_mapping) 
     1107Procedure(mapping) :: external_mapping 
     1108 
     1109agrif_external_mapping => external_mapping 
     1110 
     1111end subroutine Agrif_Set_ExternalMapping 
     1112 
     1113! Set the name of the user linear interp function (if needed) 
     1114subroutine Agrif_Set_external_linear_interp(external_linear_interp) 
     1115Procedure(linear_interp) :: external_linear_interp 
     1116 
     1117agrif_external_linear_interp => external_linear_interp 
     1118 
     1119end subroutine Agrif_Set_external_linear_interp 
     1120 
     1121subroutine Agrif_UnSet_external_linear_interp() 
     1122 
     1123nullify(agrif_external_linear_interp) 
     1124 
     1125end subroutine Agrif_UnSet_external_linear_interp 
     1126 
    7651127end module Agrif_CurgridFunctions 

  • vendors/AGRIF/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modgrids.F90

    r5656 r13027  
    4747    real   , dimension(3)              :: Agrif_dx  !< global space step in the x, y and z direction 
    4848    real   , dimension(3)              :: Agrif_dt  !< global time  step in the x, y and z direction 
    49     integer, dimension(3)              :: nb        !< number of cells in the x, y and z direction 
     49    integer, dimension(3)              :: nb = 1    !< number of cells in the x, y and z direction 
    5050    integer, dimension(3)              :: ix        !< minimal position in the x, y and z direction 
    5151    integer, dimension(3)              :: spaceref  !< space refinement factor in the x, y and z direction 
    … …  
    8888    logical                             :: allocation_is_done = .false. 
    8989    logical                             :: grand_mother_grid = .false. 
     90    logical,dimension(4)                :: periodicity = .false. 
     91    integer,dimension(4)                :: periodicity_decal = 0 
    9092!--------------------------------------------------------------------------------------------------- 
    9193end type Agrif_Grid 
    … …  
    104106!> Pointer to the current grid (the link is done by using the Agrif_Instance procedure (\see module Agrif_Init)) 
    105107type(Agrif_Grid) , pointer :: Agrif_Curgrid => NULL() 
     108 
     109!> Pointer to the current child grid (the link is done before calls to procname) 
     110type(Agrif_Grid) , pointer :: Agrif_CurChildgrid => NULL() 
    106111! 
    107112!=================================================================================================== 

  • vendors/AGRIF/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modinterp.F90

    r7752 r13027  
    127127! 
    128128    INTEGER                       :: i,j,k,l,m,n 
     129    integer :: i1,j1,k1 
    129130    INTEGER, DIMENSION(nbdim)     :: pttruetab,cetruetab 
    130131    INTEGER, DIMENSION(nbdim)     :: indmin,     indmax 
    … …  
    132133#if defined AGRIF_MPI 
    133134    INTEGER, DIMENSION(nbdim)     :: indminglob2,indmaxglob2 
     135    INTEGER, DIMENSION(nbdim)     :: indminglob3,indmaxglob3 
     136    INTEGER, DIMENSION(:,:),ALLOCATABLE :: indminglob_chunks, indmaxglob_chunks 
     137    INTEGER, DIMENSION(:,:),ALLOCATABLE :: indminglob2_chunks,indmaxglob2_chunks 
     138    INTEGER, DIMENSION(:,:),ALLOCATABLE :: indminglob3_chunks,indmaxglob3_chunks 
    134139#endif 
    135140    LOGICAL, DIMENSION(nbdim)     :: noraftab 
    … …  
    138143    INTEGER, DIMENSION(nbdim,2,2), INTENT(OUT) :: childarray 
    139144    INTEGER, DIMENSION(nbdim,2,2)              :: parentarray 
     145    INTEGER, DIMENSION(nbdim,2,2)              :: parentarray_decal 
    140146    LOGICAL :: member 
     147    LOGICAL,DIMENSION(:),ALLOCATABLE :: member_chuncks 
     148    INTEGER,DIMENSION(:,:),ALLOCATABLE :: decal_chunks 
    141149    LOGICAL :: find_list_interp 
    142150! 
    … …  
    148156    INTEGER, DIMENSION(nbdim,4,0:Agrif_Nbprocs-1)   :: tab4 
    149157    INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1,8)   :: tab4t 
     158    INTEGER, DIMENSION(nbdim,2) :: tab5 
     159    INTEGER, DIMENSION(nbdim,2,0:Agrif_Nbprocs-1) :: tab6 
     160    INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1,2) :: tab5t 
    150161    LOGICAL, DIMENSION(0:Agrif_Nbprocs-1)           :: memberinall 
    151162    LOGICAL, DIMENSION(0:Agrif_Nbprocs-1)           :: sendtoproc1, recvfromproc1 
    … …  
    154165! 
    155166#endif 
     167! CHUNK (periodicity) 
     168    INTEGER :: nb_chunks 
     169    INTEGER :: agrif_external_switch_index 
     170    INTEGER, DIMENSION(2) :: test_orientation 
     171    !INTEGER, DIMENSION(2,nbdim,2,2) :: parentarray_chunk 
     172    INTEGER, DIMENSION(:,:,:,:), ALLOCATABLE :: parentarray_chunk 
     173    INTEGER, DIMENSION(:,:,:,:), ALLOCATABLE :: parentarray_chunk_decal 
     174    INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: bounds_chunks 
     175    logical,dimension(:),allocatable :: correction_required 
    156176! 
    157177    type(Agrif_Variable), pointer, save :: tempC => NULL()        ! Temporary child grid variable 
    … …  
    168188            pttab, petab, pttab_Child, pttab_Parent, nbdim,         & 
    169189            indmin, indmax, indminglob, indmaxglob,                 & 
    170             pttruetab, cetruetab, memberin                          & 
     190            pttruetab, cetruetab, memberin,                         & 
     191            parentarray_chunk,parentarray_chunk_decal,decal_chunks,  & 
     192            correction_required,member_chuncks,nb_chunks            & 
    171193#if defined AGRIF_MPI 
    172194           ,indminglob2, indmaxglob2, parentarray,                  & 
    … …  
    181203                               pttab, petab, Agrif_Procrank, coords,        & 
    182204                               pttruetab, cetruetab, memberin) 
     205 
     206        if (agrif_debug_interp) then 
     207        print *,'************CHILDBOUNDS*********************************' 
     208#ifdef AGRIF_MPI 
     209         print *,'Processeur ',Agrif_Procrank 
     210#endif 
     211        print *,'memberin ',memberin 
     212        do i = 1 , nbdim 
     213        print *,'Direction ',i,' indices debut: ',pttab(i),pttruetab(i) 
     214        print *,'Direction ',i,' indices fin  : ',petab(i),cetruetab(i) 
     215        enddo 
     216        print *,'*********************************************' 
     217        endif 
     218 
    183219        call Agrif_Parentbounds(type_interp,nbdim,indminglob,indmaxglob,    & 
    184220                                s_Parent_temp,s_Child_temp,                 & 
    … …  
    188224                                pttab_Child,pttab_Parent,                   & 
    189225                                child%root_var % posvar, coords) 
     226 
     227        if (agrif_debug_interp) then 
     228        print *,'************PARENTBOUNDS*********************************' 
     229#ifdef AGRIF_MPI 
     230         print *,'Processeur ',Agrif_Procrank 
     231#endif 
     232        do i = 1 , nbdim 
     233        print *,'Direction ',i,' indices debut: ',pttab(i),indminglob(i) 
     234        print *,'Direction ',i,' indices fin  : ',petab(i),indmaxglob(i) 
     235        enddo 
     236 
     237        do i = 1 , nbdim 
     238        print *,'Direction ',i,' s_parent_temp: ',s_parent_temp(i) 
     239        print *,'Direction ',i,' s_Child_temp : ',s_Child_temp(i) 
     240        enddo 
     241        print *,'*********************************************' 
     242        endif 
     243 
    190244#if defined AGRIF_MPI 
    191245        if (memberin) then 
    … …  
    197251                                    pttab_Child,pttab_Parent,               & 
    198252                                    child%root_var % posvar, coords) 
     253 
     254        endif 
     255        if (agrif_debug_interp) then 
     256        print *,'************PARENTBOUNDSMPI*********************************' 
     257#ifdef AGRIF_MPI 
     258         print *,'Processeur ',Agrif_Procrank 
     259#endif 
     260        do i = 1 , nbdim 
     261        print *,'Direction ',i,' indices debut: ',pttruetab(i),indmin(i) 
     262        print *,'Direction ',i,' indices fin  : ',cetruetab(i),indmax(i) 
     263        enddo 
     264 
     265        do i = 1 , nbdim 
     266        print *,'Direction ',i,' s_parent_temp: ',s_parent_temp(i) 
     267        print *,'Direction ',i,' s_Child_temp : ',s_Child_temp(i) 
     268        enddo 
     269        print *,'*********************************************' 
    199270        endif 
    200271 
    … …  
    202273        call Agrif_get_var_bounds_array(parent,lowerbound,upperbound,nbdim) 
    203274        call Agrif_ChildGrid_to_ParentGrid() 
    204 ! 
    205         call Agrif_Childbounds(nbdim,lowerbound,upperbound,                 & 
    206                                indminglob,indmaxglob, local_proc, coords,   & 
    207                                indminglob2,indmaxglob2,member) 
    208 ! 
    209         if (member) then 
    210             call Agrif_GlobalToLocalBounds(parentarray,                     & 
    211                                            lowerbound,  upperbound,         & 
    212                                            indminglob2, indmaxglob2, coords,& 
    213                                            nbdim, local_proc, member) 
     275 
     276          parentarray(:,1,1) = indminglob 
     277          parentarray(:,2,1) = indmaxglob 
     278          parentarray(:,1,2) = indminglob 
     279          parentarray(:,2,2) = indmaxglob 
     280 
     281        if (associated(agrif_external_mapping)) then 
     282 
     283          call agrif_external_mapping(nbdim,child%root_var % posvar(1),child%root_var % posvar(2), & 
     284                                      parentarray,parentarray_chunk,correction_required,nb_chunks) 
     285          allocate(decal_chunks(nb_chunks,nbdim)) 
     286          do i=1,nb_chunks 
     287            decal_chunks(i,:)=parentarray_chunk(i,:,1,1)-parentarray_chunk(i,:,1,2) 
     288          enddo 
     289        else 
     290            nb_chunks=1 
     291            allocate(correction_required(nb_chunks)) 
     292            correction_required=.FALSE. 
     293            allocate(parentarray_chunk(nb_chunks,nbdim,2,2)) 
     294            parentarray_chunk(1,:,:,:)=parentarray 
     295            allocate(decal_chunks(nb_chunks,nbdim)) 
     296            decal_chunks=0 
    214297        endif 
     298        if (agrif_debug_interp) then 
     299        print *,'AVANT PARENTCHILDBOUNDS' 
     300        print *,'nombre de chunks ',nb_chunks 
     301        do i=1,nb_chunks 
     302          print *,'CHUNK Number : ',i 
     303          do j=1,nbdim 
     304           print *,'Direction ',j 
     305           print *,'MIN MAX (2) = ',parentarray_chunk(i,j,1,2),parentarray_chunk(i,j,2,2) 
     306           print *,'MIN MAX (1) = ',parentarray_chunk(i,j,1,1),parentarray_chunk(i,j,2,1) 
     307          enddo 
     308        enddo 
     309        print *,'APRES PARENTCHILDBOUNDS' 
     310        endif 
     311 
     312        allocate(indminglob_chunks(nb_chunks,nbdim)) 
     313        allocate(indmaxglob_chunks(nb_chunks,nbdim)) 
     314        allocate(indminglob2_chunks(nb_chunks,nbdim)) 
     315        allocate(indmaxglob2_chunks(nb_chunks,nbdim)) 
     316        allocate(indminglob3_chunks(nb_chunks,nbdim)) 
     317        allocate(indmaxglob3_chunks(nb_chunks,nbdim)) 
     318        allocate(member_chuncks(nb_chunks)) 
     319 
     320        do i=1,nb_chunks 
     321          indminglob_chunks(i,:) = parentarray_chunk(i,:,1,2) 
     322          indmaxglob_chunks(i,:) = parentarray_chunk(i,:,2,2) 
     323        enddo 
     324 
     325        do i=1,nb_chunks 
     326 
     327              call Agrif_Childbounds(nbdim,lowerbound,upperbound,         & 
     328                   indminglob_chunks(i,:),indmaxglob_chunks(i,:), local_proc, coords,   & 
     329                   indminglob2_chunks(i,:),indmaxglob2_chunks(i,:),member_chuncks(i),   & 
     330                   indminglob3_chunks(i,:),indmaxglob3_chunks(i,:)) 
     331        enddo 
     332! 
     333        ! call Agrif_Childbounds(nbdim,lowerbound,upperbound,                 & 
     334                               ! indminglob,indmaxglob, local_proc, coords,   & 
     335                               ! indminglob2,indmaxglob2,member,              & 
     336                               ! indminglob3,indmaxglob3,check_perio=.TRUE.) 
     337 
     338        if (agrif_debug_interp) then 
     339        print *,'************CHILDBOUNDSPARENTMPI*********************************' 
     340#ifdef AGRIF_MPI 
     341         print *,'Processeur ',Agrif_Procrank 
     342#endif 
     343        do j=1,nb_chunks 
     344        print *,'Chunk number ',j 
     345 
     346        do i = 1 , nbdim 
     347        print *,'Direction ',i,' indices debut: ',indminglob_chunks(j,i),indminglob2_chunks(j,i),indminglob3_chunks(j,i) 
     348        print *,'Direction ',i,' indices fin  : ',indmaxglob_chunks(j,i),indmaxglob2_chunks(j,i),indmaxglob3_chunks(j,i) 
     349        enddo 
     350        enddo 
     351        print *,'*********************************************' 
     352        endif 
     353! 
     354        ! if (member) then 
     355            ! call Agrif_GlobalToLocalBounds(parentarray,                     & 
     356                                           ! lowerbound,  upperbound,         & 
     357                                           ! indminglob2, indmaxglob2, coords,& 
     358                                           ! nbdim, local_proc, member,check_perio=.TRUE.) 
     359            ! if (agrif_debug_interp) then 
     360            ! do i=1,nbdim 
     361            ! print *,'parentarray = ',i,parentarray(i,1,1),parentarray(i,2,1), & 
     362                ! parentarray(i,1,2),parentarray(i,2,2) 
     363            ! enddo 
     364            ! endif 
     365        ! endif 
     366 
     367        allocate(parentarray_chunk_decal(nb_chunks,nbdim,2,2)) 
     368        do j=1,nb_chunks 
     369        if (agrif_debug_interp) print *,'CHUNK = ',j 
     370        if (member_chuncks(j)) then 
     371            ! call Agrif_GlobalToLocalBounds(parentarray_chunk(j,:,:,:),                               & 
     372                                           ! lowerbound,  upperbound,                                  & 
     373                                           ! indminglob2_chunks(j,:), indmaxglob2_chunks(j,:), coords, & 
     374                                           ! nbdim, local_proc, member_chuncks(j),check_perio=.TRUE.) 
     375 
     376            call Agrif_GlobalToLocalBounds(parentarray_chunk(j,:,:,:),                               & 
     377                                           lowerbound,  upperbound,                                  & 
     378                                           indminglob2_chunks(j,:), indmaxglob2_chunks(j,:), coords, & 
     379                                           nbdim, local_proc, member_chuncks(j)) 
     380 
     381            if (correction_required(j)) then 
     382                do i=1,2 
     383                    test_orientation(1)=agrif_external_switch_index(child%root_var % posvar(1),child%root_var % posvar(2), & 
     384                    parentarray_chunk(j,i,1,1),i) 
     385                    test_orientation(2)=agrif_external_switch_index(child%root_var % posvar(1),child%root_var % posvar(2), & 
     386                    parentarray_chunk(j,i,2,1),i) 
     387                    parentarray_chunk_decal(j,i,1,1)=minval(test_orientation) 
     388                    parentarray_chunk_decal(j,i,2,1)=maxval(test_orientation) 
     389                enddo 
     390                do i=3,nbdim 
     391                  parentarray_chunk_decal(j,i,:,1) = parentarray_chunk(j,i,:,1)+decal_chunks(j,i) 
     392                enddo 
     393            else 
     394            do i=1,nbdim 
     395            parentarray_chunk_decal(j,i,:,1) = parentarray_chunk(j,i,:,1)+decal_chunks(j,i) 
     396            enddo 
     397            endif 
     398 
     399            if (agrif_debug_interp) then 
     400            do i=1,nbdim 
     401            print *,'parentarray = ',i,parentarray_chunk(j,i,1,1),parentarray_chunk(j,i,2,1), & 
     402                parentarray_chunk(j,i,1,2),parentarray_chunk(j,i,2,2) 
     403                print *,'parentarraydecal = ',i,parentarray_chunk_decal(j,i,1,1),parentarray_chunk_decal(j,i,2,1) 
     404            enddo 
     405            endif 
     406        endif 
     407        enddo 
     408 
     409        parentarray(:,1,:)=Huge(1) 
     410        parentarray(:,2,:)=-Huge(1) 
     411        indminglob2=Huge(1) 
     412        indmaxglob2=-Huge(1) 
     413        indminglob3=Huge(1) 
     414        indmaxglob3=-Huge(1) 
     415        member = .FALSE. 
     416        do j=1,nb_chunks 
     417          if (member_chuncks(j)) then 
     418                           do i=1,nbdim 
     419             parentarray(i,1,1) = min(parentarray(i,1,1),parentarray_chunk_decal(j,i,1,1)) 
     420             parentarray(i,1,2) = min(parentarray(i,1,2),parentarray_chunk(j,i,1,2)) 
     421             parentarray(i,2,1) = max(parentarray(i,2,1),parentarray_chunk_decal(j,i,2,1)) 
     422             parentarray(i,2,2) = max(parentarray(i,2,2),parentarray_chunk(j,i,2,2)) 
     423                         enddo 
     424            if (correction_required(j)) then 
     425               if (agrif_debug_interp) then 
     426                  do i=1,nbdim 
     427                     print *,'direction ',i 
     428                  print *,'glob2_chuk = ',indminglob2_chunks(j,i),indmaxglob2_chunks(j,i) 
     429                  print *,'glob3_chuk = ',indminglob3_chunks(j,i),indmaxglob3_chunks(j,i) 
     430               enddo 
     431               endif 
     432                do i=1,2 
     433                    test_orientation(1)=agrif_external_switch_index(child%root_var % posvar(1),child%root_var % posvar(2), & 
     434                    indminglob2_chunks(j,i),i) 
     435                    test_orientation(2)=agrif_external_switch_index(child%root_var % posvar(1),child%root_var % posvar(2), & 
     436                    indmaxglob2_chunks(j,i),i) 
     437                    indminglob2(i)=min(indminglob2(i),minval(test_orientation)) 
     438                    indmaxglob2(i)=max(indmaxglob2(i),maxval(test_orientation)) 
     439                enddo 
     440 
     441                do i=1,2 
     442                    test_orientation(1)=agrif_external_switch_index(child%root_var % posvar(1),child%root_var % posvar(2), & 
     443                    indminglob3_chunks(j,i),i) 
     444                    test_orientation(2)=agrif_external_switch_index(child%root_var % posvar(1),child%root_var % posvar(2), & 
     445                    indmaxglob3_chunks(j,i),i) 
     446                    indminglob3(i)=min(indminglob3(i),minval(test_orientation)) 
     447                    indmaxglob3(i)=max(indmaxglob3(i),maxval(test_orientation)) 
     448                enddo 
     449 
     450                do i=3,nbdim 
     451             indminglob2(i)=min(indminglob2(i),indminglob2_chunks(j,i)+decal_chunks(j,i)) 
     452             indmaxglob2(i)=max(indmaxglob2(i),indmaxglob2_chunks(j,i)+decal_chunks(j,i)) 
     453             indminglob3(i)=min(indminglob3(i),indminglob3_chunks(j,i)+decal_chunks(j,i)) 
     454             indmaxglob3(i)=max(indmaxglob3(i),indmaxglob3_chunks(j,i)+decal_chunks(j,i)) 
     455                enddo 
     456            else 
     457                           do i=1,nbdim 
     458             indminglob2(i)=min(indminglob2(i),indminglob2_chunks(j,i)+decal_chunks(j,i)) 
     459             indmaxglob2(i)=max(indmaxglob2(i),indmaxglob2_chunks(j,i)+decal_chunks(j,i)) 
     460             indminglob3(i)=min(indminglob3(i),indminglob3_chunks(j,i)+decal_chunks(j,i)) 
     461             indmaxglob3(i)=max(indmaxglob3(i),indmaxglob3_chunks(j,i)+decal_chunks(j,i)) 
     462                         enddo 
     463         endif 
     464 
     465            member = .TRUE. 
     466          endif 
     467        enddo 
    215468 
    216469        call Agrif_ParentGrid_to_ChildGrid() 
     470 
     471        if (agrif_debug_interp) then 
     472        print *,'************ FINAL PARENTARRAY *****************' 
     473#ifdef AGRIF_MPI 
     474        print *,'Processeur ',Agrif_Procrank,' MEMBER = ',member 
     475        do i=1,nbdim 
     476         print *,'Direction ',i,' indices debut = ',parentarray(i,1,1),parentarray(i,1,2) 
     477         print *,'Direction ',i,' indices fin = ',parentarray(i,2,1),parentarray(i,2,2) 
     478        enddo 
     479#endif 
     480        endif 
     481 
     482        if (agrif_debug_interp) then 
     483        print *,'************ FINAL INDMINGLOB *****************' 
     484#ifdef AGRIF_MPI 
     485        print *,'Processeur ',Agrif_Procrank,' MEMBER = ',member 
     486        do i=1,nbdim 
     487         print *,'Direction ',i,' indices debut = ',indminglob2(i),indminglob3(i) 
     488         print *,'Direction ',i,' indices fin = ',indmaxglob2(i),indmaxglob3(i) 
     489        enddo 
     490#endif 
     491        endif 
     492 
    217493#else 
    218494        parentarray(:,1,1) = indminglob 
    … …  
    220496        parentarray(:,1,2) = indminglob 
    221497        parentarray(:,2,2) = indmaxglob 
     498 
     499 
     500        if (associated(agrif_external_mapping)) then 
     501          call Agrif_ChildGrid_to_ParentGrid() 
     502          call agrif_external_mapping(nbdim,child%root_var % posvar(1),child%root_var % posvar(2), & 
     503                                      parentarray,parentarray_chunk,correction_required,nb_chunks) 
     504          call Agrif_ParentGrid_to_ChildGrid() 
     505          allocate(decal_chunks(nb_chunks,nbdim)) 
     506          do i=1,nb_chunks 
     507            decal_chunks(i,:)=parentarray_chunk(i,:,1,1)-parentarray_chunk(i,:,1,2) 
     508          enddo 
     509        else 
     510            nb_chunks=1 
     511            allocate(correction_required(nb_chunks)) 
     512            correction_required=.FALSE. 
     513            allocate(parentarray_chunk(nb_chunks,nbdim,2,2)) 
     514            parentarray_chunk(1,:,:,:)=parentarray 
     515        endif 
     516        if (agrif_debug_interp) then 
     517        print *,'AVANT PARENTCHILDBOUNDS' 
     518        print *,'nombre de chunks ',nb_chunks 
     519        do i=1,nb_chunks 
     520          print *,'CHUNK Number : ',i 
     521          do j=1,nbdim 
     522           print *,'Direction ',j 
     523           print *,'MIN MAX (2) = ',parentarray_chunk(i,j,1,2),parentarray_chunk(i,j,2,2) 
     524           print *,'MIN MAX (1) = ',parentarray_chunk(i,j,1,1),parentarray_chunk(i,j,2,1) 
     525          enddo 
     526        enddo 
     527        print *,'APRES PARENTCHILDBOUNDS' 
     528        endif 
     529        allocate(member_chuncks(nb_chunks)) 
     530        allocate(parentarray_chunk_decal(nb_chunks,nbdim,2,2)) 
     531        member_chuncks = .TRUE. 
     532        member = .TRUE. 
     533        do j=1,nb_chunks 
     534        if (agrif_debug_interp) print *,'CHUNK = ',j 
     535        if (member_chuncks(j)) then 
     536            do i=1,nbdim 
     537            parentarray_chunk_decal(j,i,:,1) = parentarray_chunk(j,i,:,1)   !+decal_chunks(j,i) 
     538            if (agrif_debug_interp) then 
     539                print *,'ENCORE = ',parentarray_chunk(j,i,:,1),parentarray_chunk_decal(j,i,:,1) 
     540            endif 
     541            enddo 
     542            if (agrif_debug_interp) then 
     543            do i=1,nbdim 
     544            print *,'parentarray = ',i,parentarray_chunk(j,i,1,1),parentarray_chunk(j,i,2,1), & 
     545                parentarray_chunk(j,i,1,2),parentarray_chunk(j,i,2,2) 
     546                print *,'parentarraydecal = ',i,parentarray_chunk_decal(j,i,1,1),parentarray_chunk_decal(j,i,2,1) 
     547            enddo 
     548            endif 
     549        endif 
     550        enddo 
     551 
     552 
    222553        indmin = indminglob 
    223554        indmax = indmaxglob 
    224555        member = .TRUE. 
    225556#endif 
     557!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
     558! Correct for non refined directions 
     559!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
     560        do i=1,nbdim 
     561          if (coords(i) == 0) then 
     562             indmin(i) = indminglob(i) 
     563             indmax(i) = indmaxglob(i) 
     564             pttruetab(i) = indminglob(i) 
     565             cetruetab(i) = indmaxglob(i) 
     566          endif 
     567        enddo 
    226568 
    227569    else 
    … …  
    241583        s_Child_temp  = s_Child + (pttab - pttab_Child) * ds_Child 
    242584#endif 
     585 
    243586    endif 
     587 
     588        if (agrif_debug_interp) then 
     589        print *,'************SPARENTCHILD*********************************' 
     590#ifdef AGRIF_MPI 
     591         print *,'Processeur ',Agrif_Procrank 
     592#endif 
     593        do i = 1 , nbdim 
     594        print *,'Direction ',i,' s_Parent_temp : ',s_Parent_temp(i),indmin(i) 
     595        print *,'Direction ',i,' s_Child_temp  : ',s_Child_temp(i),pttruetab(i) 
     596        enddo 
     597        print *,'*********************************************' 
     598        endif 
     599 
     600    call Agrif_get_var_bounds_array(parent,lowerbound,upperbound,nbdim) 
    244601! 
    245602    if (member) then 
    … …  
    248605        call Agrif_array_allocate(tempP,parentarray(:,1,1),parentarray(:,2,1),nbdim) 
    249606        call Agrif_var_set_array_tozero(tempP,nbdim) 
    250  
    251         call Agrif_ChildGrid_to_ParentGrid() 
    252 ! 
     607    endif 
     608    Agrif_CurChildgrid=>Agrif_Curgrid 
     609    call Agrif_ChildGrid_to_ParentGrid() 
     610    do i=1,nb_chunks 
     611    if (agrif_debug_interp) then 
     612    print *,'PROCNAME POUR CHUCNK ',i 
     613    endif 
     614 
     615    if (member_chuncks(i)) then 
    253616        select case (nbdim) 
    254617        case(1) 
    255             call procname(tempP%array1,                         & 
    256                       parentarray(1,1,2),parentarray(1,2,2),.TRUE.,nb,ndir) 
     618            ! call procname(tempP%array1,                         & 
     619            !           parentarray(1,1,2),parentarray(1,2,2),.TRUE.,nb,ndir) 
     620 
     621            call procname(tempP%array1(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1)),         & 
     622                      parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2),.TRUE.,nb,ndir) 
     623 
    257624        case(2) 
    258             call procname(tempP%array2,                         & 
    259                       parentarray(1,1,2),parentarray(1,2,2),    & 
    260                       parentarray(2,1,2),parentarray(2,2,2),.TRUE.,nb,ndir) 
     625            ! call procname(tempP%array2,                         & 
     626                      ! parentarray(1,1,2),parentarray(1,2,2),    & 
     627                      ! parentarray(2,1,2),parentarray(2,2,2),.TRUE.,nb,ndir) 
     628 
     629            call procname(tempP%array2(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 
     630                      parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1)),         & 
     631                      parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2),    & 
     632                      parentarray_chunk(i,2,1,2),parentarray_chunk(i,2,2,2),.TRUE.,nb,ndir) 
     633            if (agrif_debug_interp) print *,'SORTIE DE PROCNAME' 
     634            if (correction_required(i)) then 
     635             call correct_field(tempP%array2(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 
     636                      parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1)), & 
     637                      parentarray_chunk_decal(i,1,1,1),parentarray_chunk_decal(i,1,2,1), & 
     638                      parentarray_chunk_decal(i,2,1,1),parentarray_chunk_decal(i,2,2,1)) 
     639            endif 
     640 
    261641        case(3) 
    262             call procname(tempP%array3,                         & 
    263                       parentarray(1,1,2),parentarray(1,2,2),    & 
    264                       parentarray(2,1,2),parentarray(2,2,2),    & 
    265                       parentarray(3,1,2),parentarray(3,2,2),.TRUE.,nb,ndir) 
     642            call procname(tempP%array3(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 
     643                      parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1), & 
     644                      parentarray_chunk_decal(i,3,1,1):parentarray_chunk_decal(i,3,2,1)),                 & 
     645                      parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2),    & 
     646                      parentarray_chunk(i,2,1,2),parentarray_chunk(i,2,2,2),    & 
     647                      parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2),.TRUE.,nb,ndir) 
     648 
     649            if (agrif_debug_interp) then 
     650                print *,'CHUNK = ',i 
     651                print *,'NBNDIR = ',nb,ndir,correction_required(i) 
     652                print *,'TEMPARRAY3 INDEX LOCAUX PUIS GLOBAUX' 
     653                print *,parentarray_chunk_decal(i,1,1,1),parentarray_chunk_decal(i,1,2,1) 
     654                print *,parentarray_chunk_decal(i,2,1,1),parentarray_chunk_decal(i,2,2,1) 
     655                print *,parentarray_chunk_decal(i,3,1,1),parentarray_chunk_decal(i,3,2,1) 
     656                print *,parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2) 
     657                print *,parentarray_chunk(i,2,1,2),parentarray_chunk(i,2,2,2) 
     658                print *,parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2) 
     659                do j1=parentarray_chunk_decal(i,2,1,1),parentarray_chunk_decal(i,2,2,1) 
     660                    do i1=parentarray_chunk_decal(i,1,1,1),parentarray_chunk_decal(i,1,2,1) 
     661                        print *,'valprocname = ',i1,j1,tempP%array3(i1,j1,1) 
     662                    enddo 
     663                enddo 
     664            endif 
     665            if (correction_required(i)) then 
     666                do k=parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2) 
     667             call correct_field(tempP%array3(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 
     668                      parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1),k), & 
     669                      parentarray_chunk_decal(i,1,1,1),parentarray_chunk_decal(i,1,2,1), & 
     670                      parentarray_chunk_decal(i,2,1,1),parentarray_chunk_decal(i,2,2,1)) 
     671                enddo 
     672            if (agrif_debug_interp) then 
     673                do j1=parentarray_chunk_decal(i,2,1,1),parentarray_chunk_decal(i,2,2,1) 
     674                    do i1=parentarray_chunk_decal(i,1,1,1),parentarray_chunk_decal(i,1,2,1) 
     675                        print *,'valprocname apres correction = ',i1,j1,tempP%array3(i1,j1,1) 
     676                    enddo 
     677                enddo 
     678            endif 
     679            endif 
     680 
     681            ! call procname(tempP%array3,                         & 
     682                      ! parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2),    & 
     683                      ! parentarray_chunk(i,2,1,2),parentarray_chunk(i,2,2,2),    & 
     684                      ! parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2),.TRUE.,nb,ndir) 
    266685        case(4) 
    267             call procname(tempP%array4,                         & 
    268                       parentarray(1,1,2),parentarray(1,2,2),    & 
    269                       parentarray(2,1,2),parentarray(2,2,2),    & 
    270                       parentarray(3,1,2),parentarray(3,2,2),    & 
    271                       parentarray(4,1,2),parentarray(4,2,2),.TRUE.,nb,ndir) 
     686 
     687            call procname(tempP%array4(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 
     688                      parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1), & 
     689                      parentarray_chunk_decal(i,3,1,1):parentarray_chunk_decal(i,3,2,1), & 
     690                      parentarray_chunk_decal(i,4,1,1):parentarray_chunk_decal(i,4,2,1)),                 & 
     691                      parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2),    & 
     692                      parentarray_chunk(i,2,1,2),parentarray_chunk(i,2,2,2),    & 
     693                      parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2),    & 
     694                      parentarray_chunk(i,4,1,2),parentarray_chunk(i,4,2,2),.TRUE.,nb,ndir) 
     695 
     696            if (correction_required(i)) then 
     697                do l=parentarray_chunk(i,4,1,2),parentarray_chunk(i,4,2,2) 
     698                do k=parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2) 
     699             call correct_field(tempP%array4(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 
     700                      parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1),k,l), & 
     701                      parentarray_chunk_decal(i,1,1,1),parentarray_chunk_decal(i,1,2,1), & 
     702                      parentarray_chunk_decal(i,2,1,1),parentarray_chunk_decal(i,2,2,1)) 
     703                enddo 
     704            enddo 
     705            endif 
     706 
     707            ! call procname(tempP%array4,                         & 
     708            !           parentarray(1,1,2),parentarray(1,2,2),    & 
     709            !           parentarray(2,1,2),parentarray(2,2,2),    & 
     710            !           parentarray(3,1,2),parentarray(3,2,2),    & 
     711            !           parentarray(4,1,2),parentarray(4,2,2),.TRUE.,nb,ndir) 
    272712        case(5) 
    273             call procname(tempP%array5,                         & 
    274                       parentarray(1,1,2),parentarray(1,2,2),    & 
    275                       parentarray(2,1,2),parentarray(2,2,2),    & 
    276                       parentarray(3,1,2),parentarray(3,2,2),    & 
    277                       parentarray(4,1,2),parentarray(4,2,2),    & 
    278                       parentarray(5,1,2),parentarray(5,2,2),.TRUE.,nb,ndir) 
     713 
     714            call procname(tempP%array5(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 
     715                      parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1), & 
     716                      parentarray_chunk_decal(i,3,1,1):parentarray_chunk_decal(i,3,2,1), & 
     717                      parentarray_chunk_decal(i,4,1,1):parentarray_chunk_decal(i,4,2,1), & 
     718                      parentarray_chunk_decal(i,5,1,1):parentarray_chunk_decal(i,5,2,1)),                 & 
     719                      parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2),    & 
     720                      parentarray_chunk(i,2,1,2),parentarray_chunk(i,2,2,2),    & 
     721                      parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2),    & 
     722                      parentarray_chunk(i,4,1,2),parentarray_chunk(i,4,2,2),    & 
     723                      parentarray_chunk(i,5,1,2),parentarray_chunk(i,5,2,2),.TRUE.,nb,ndir) 
     724 
     725            if (correction_required(i)) then 
     726                do m=parentarray_chunk(i,5,1,2),parentarray_chunk(i,5,2,2) 
     727                do l=parentarray_chunk(i,4,1,2),parentarray_chunk(i,4,2,2) 
     728                do k=parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2) 
     729             call correct_field(tempP%array5(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 
     730                      parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1),k,l,m), & 
     731                      parentarray_chunk_decal(i,1,1,1),parentarray_chunk_decal(i,1,2,1), & 
     732                      parentarray_chunk_decal(i,2,1,1),parentarray_chunk_decal(i,2,2,1)) 
     733                enddo 
     734            enddo 
     735            enddo 
     736            endif 
     737 
     738            ! call procname(tempP%array5,                         & 
     739            !           parentarray(1,1,2),parentarray(1,2,2),    & 
     740            !           parentarray(2,1,2),parentarray(2,2,2),    & 
     741            !           parentarray(3,1,2),parentarray(3,2,2),    & 
     742            !           parentarray(4,1,2),parentarray(4,2,2),    & 
     743            !           parentarray(5,1,2),parentarray(5,2,2),.TRUE.,nb,ndir) 
    279744        case(6) 
    280             call procname(tempP%array6,                         & 
    281                       parentarray(1,1,2),parentarray(1,2,2),    & 
    282                       parentarray(2,1,2),parentarray(2,2,2),    & 
    283                       parentarray(3,1,2),parentarray(3,2,2),    & 
    284                       parentarray(4,1,2),parentarray(4,2,2),    & 
    285                       parentarray(5,1,2),parentarray(5,2,2),    & 
    286                       parentarray(6,1,2),parentarray(6,2,2),.TRUE.,nb,ndir) 
     745 
     746            call procname(tempP%array6(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 
     747                      parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1), & 
     748                      parentarray_chunk_decal(i,3,1,1):parentarray_chunk_decal(i,3,2,1), & 
     749                      parentarray_chunk_decal(i,4,1,1):parentarray_chunk_decal(i,4,2,1), & 
     750                      parentarray_chunk_decal(i,5,1,1):parentarray_chunk_decal(i,5,2,1), & 
     751                      parentarray_chunk_decal(i,6,1,1):parentarray_chunk_decal(i,6,2,1)),                 & 
     752                      parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2),    & 
     753                      parentarray_chunk(i,2,1,2),parentarray_chunk(i,2,2,2),    & 
     754                      parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2),    & 
     755                      parentarray_chunk(i,4,1,2),parentarray_chunk(i,4,2,2),    & 
     756                      parentarray_chunk(i,5,1,2),parentarray_chunk(i,5,2,2),    & 
     757                      parentarray_chunk(i,6,1,2),parentarray_chunk(i,6,2,2),.TRUE.,nb,ndir) 
     758 
     759            ! call procname(tempP%array6,                         & 
     760            !           parentarray(1,1,2),parentarray(1,2,2),    & 
     761            !           parentarray(2,1,2),parentarray(2,2,2),    & 
     762            !           parentarray(3,1,2),parentarray(3,2,2),    & 
     763            !           parentarray(4,1,2),parentarray(4,2,2),    & 
     764            !           parentarray(5,1,2),parentarray(5,2,2),    & 
     765            !           parentarray(6,1,2),parentarray(6,2,2),.TRUE.,nb,ndir) 
    287766        end select 
    288767! 
    289         call Agrif_ParentGrid_to_ChildGrid() 
    290768! 
    291769    endif 
     770    enddo 
     771    call Agrif_ParentGrid_to_ChildGrid() 
     772    nullify(Agrif_CurChildgrid) 
    292773 
    293774#if defined AGRIF_MPI 
    … …  
    298779        tab3(:,3) = indmin(:) 
    299780        tab3(:,4) = indmax(:) 
     781        tab5(:,1) = indminglob3(:) 
     782        tab5(:,2) = indmaxglob3(:) 
     783        if (agrif_debug_interp) then 
     784         print *,'********************' 
     785         print *,'MPI VARIABLES' 
     786         print *,'INDMINGLOB2' 
     787         do i=1,nbdim 
     788            print *,'Direction ',i,indminglob2(i),indmaxglob2(i) 
     789         enddo 
     790         print *,'INDMIN' 
     791         do i=1,nbdim 
     792            print *,'Direction ',i,indmin(i),indmax(i) 
     793         enddo 
     794         print *,'INDMINGLOB3' 
     795         do i=1,nbdim 
     796            print *,'Direction ',i,indminglob3(i),indmaxglob3(i) 
     797         enddo 
     798        endif 
    300799! 
    301800        call MPI_ALLGATHER(tab3,4*nbdim,MPI_INTEGER,tab4,4*nbdim,MPI_INTEGER,Agrif_mpi_comm,code) 
    302  
     801        call MPI_ALLGATHER(tab5,2*nbdim,MPI_INTEGER,tab6,2*nbdim,MPI_INTEGER,Agrif_mpi_comm,code) 
    303802        if (.not.associated(tempPextend))   allocate(tempPextend) 
    304803 
    … …  
    309808                enddo 
    310809            enddo 
     810        enddo 
     811 
     812        do k=0,Agrif_Nbprocs-1 
     813          do j=1,2 
     814            do i=1,nbdim 
     815               tab5t(i,k,j) = tab6(i,j,k) 
     816            enddo 
     817          enddo 
    311818        enddo 
    312819 
    … …  
    319826                                     sendtoproc1,recvfromproc1,         & 
    320827                                     tab4t(:,:,5),tab4t(:,:,6),         & 
    321                                      tab4t(:,:,7),tab4t(:,:,8) ) 
     828                                     tab4t(:,:,7),tab4t(:,:,8),         & 
     829                                     tab5t(:,:,1),tab5t(:,:,2)) 
    322830    endif 
    323831 
    … …  
    335843                indminglob,indmaxglob,                          & 
    336844                pttruetab,cetruetab,                            & 
    337                 memberin,nbdim                                  & 
     845                memberin,nbdim,                                 & 
     846                parentarray_chunk,parentarray_chunk_decal,decal_chunks,& 
     847                correction_required,member_chuncks,nb_chunks    & 
    338848#if defined AGRIF_MPI 
    339849               ,indminglob2,indmaxglob2,                        & 
    … …  
    391901                                                ds_Child(1:2),    ds_Parent(1:2) ) 
    392902            case(3) 
     903                        if (agrif_debug_interp) then 
     904        print *,'APRES ECHANGE' 
     905        print *,'nombre de chunks ',nb_chunks 
     906        print *,'indmin = ',indmin 
     907        print *,'indmax = ',indmax 
     908        do i=1,nb_chunks 
     909          print *,'CHUNK Number : ',i 
     910          print *,'MEMBER = ',member_chuncks(i) 
     911          print *,'Correction = ',correction_required(i) 
     912        enddo 
     913        endif 
     914 
     915                if (agrif_debug_interp) then 
     916                !    if ((nb==1).AND.(ndir==1)) then 
     917                        print *,'valeur parent = ' 
     918                        do j=indmin(2),indmax(2) 
     919                            do i=indmin(1),indmax(1) 
     920                                print *,'par = ',i,j,tempPextend%array3(i,j,1) 
     921                            enddo 
     922                        enddo 
     923 
     924                 !   endif 
     925                endif 
    393926                call Agrif_Interp_3D_recursive( type_interp(1:3),                       & 
    394927                                                tempPextend % array3,                   & 
    … …  
    398931                                                s_Child_temp(1:3), s_Parent_temp(1:3),  & 
    399932                                                ds_Child(1:3),    ds_Parent(1:3) ) 
     933                if (agrif_debug_interp) then 
     934                  !  if ((nb==1).AND.(ndir==1)) then 
     935                        print *,'valeur enfnat = ' 
     936                        do j=pttruetab(2),cetruetab(2) 
     937                            do i=pttruetab(1),cetruetab(1) 
     938                                print *,'par = ',i,j,tempC%array3(i,j,1) 
     939                            enddo 
     940                        enddo 
     941 
     942                  !  endif 
     943                endif 
    400944            case(4) 
    401945                call Agrif_Interp_4D_recursive( type_interp(1:4),                       & 
    … …  
    6761220                                      childarray(2,1,1):childarray(2,2,1),      & 
    6771221                                      childarray(3,1,1):childarray(3,2,1)) 
     1222                if (agrif_debug_interp) then 
     1223                    if ((nb==1).AND.(ndir==1)) then 
     1224                        print *,'valeur enfnat2 = ' 
     1225                        do j=childarray(2,1,2),childarray(2,2,2) 
     1226                            do i=childarray(1,1,2),childarray(1,2,2) 
     1227                                print *,'par = ',i,j,parray3(i,j,1) 
     1228                            enddo 
     1229                        enddo 
     1230 
     1231                    endif 
     1232                endif 
    6781233                    case (4) 
    6791234                        parray4(childarray(1,1,2):childarray(1,2,2),      & 
    … …  
    7231278#if defined AGRIF_MPI 
    7241279    if (member) then 
     1280    if (agrif_debug_interp) then 
     1281    print *,'ALLCOATED 0 = ',allocated(tempP%array3),size(tempP%array3) 
     1282    endif 
    7251283        call Agrif_array_deallocate(tempP,nbdim) 
    7261284    endif 
    … …  
    7741332            indmin(i) = indmin(i) - 2 
    7751333            indmax(i) = indmax(i) + 2 
    776  
    777             if (Agrif_UseSpecialValue) then 
    778                indmin(i) = indmin(i)-MaxSearch 
    779                indmax(i) = indmax(i)+MaxSearch 
    780             endif 
    781  
    7821334        elseif ( (type_interp(i) /= Agrif_constant) .and.   & 
    7831335                 (type_interp(i) /= Agrif_linear) ) then 
    7841336            indmin(i) = indmin(i) - 1 
    7851337            indmax(i) = indmax(i) + 1 
    786  
    787             if (Agrif_UseSpecialValue) then 
    788                indmin(i) = indmin(i)-MaxSearch 
    789                indmax(i) = indmax(i)+MaxSearch 
    790             endif 
    791  
    792         elseif ( (type_interp(i) == Agrif_constant) .or.   & 
    793                  (type_interp(i) == Agrif_linear) ) then 
    794             if (Agrif_UseSpecialValue) then 
    795                indmin(i) = indmin(i)-MaxSearch 
    796                indmax(i) = indmax(i)+MaxSearch 
    797             endif 
    798  
    7991338        endif 
    8001339! 
    … …  
    13721911function Agrif_Find_list_interp ( list_interp, pttab, petab, pttab_Child, pttab_Parent,     & 
    13731912                                    nbdim, indmin, indmax, indminglob,  indmaxglob,         & 
    1374                                     pttruetab, cetruetab, memberin                          & 
     1913                                    pttruetab, cetruetab, memberin,                         & 
     1914                                    parentarray_chunk,parentarray_chunk_decal,decal_chunks,   & 
     1915                                    correction_required,member_chuncks,nb_chunks            & 
    13751916#if defined AGRIF_MPI 
    13761917                                   ,indminglob2, indmaxglob2, parentarray,                  & 
    … …  
    13861927    integer, dimension(nbdim),     intent(out) :: pttruetab, cetruetab 
    13871928    logical,                       intent(out) :: memberin 
     1929    integer :: nb_chunks 
     1930    integer, dimension(:,:,:,:), allocatable :: parentarray_chunk 
     1931    integer, dimension(:,:,:,:), allocatable :: parentarray_chunk_decal 
     1932    integer, dimension(:,:),allocatable :: decal_chunks 
     1933    logical, dimension(:),allocatable :: correction_required 
     1934    logical, dimension(:),allocatable :: member_chuncks 
    13881935#if defined AGRIF_MPI 
    13891936    integer, dimension(nbdim),     intent(out) :: indminglob2, indmaxglob2 
    … …  
    14411988#endif 
    14421989        memberin = pil % memberin 
     1990 
     1991! chunks 
     1992        nb_chunks = pil % nb_chunks 
     1993        Allocate(parentarray_chunk(nb_chunks,nbdim,2,2)) 
     1994        parentarray_chunk = pil % parentarray_chunk 
     1995        Allocate(parentarray_chunk_decal(nb_chunks,nbdim,2,2)) 
     1996        parentarray_chunk_decal = pil % parentarray_chunk_decal 
     1997        Allocate(correction_required(nb_chunks)) 
     1998        correction_required = pil % correction_required 
     1999        Allocate(decal_chunks(nb_chunks,nbdim)) 
     2000        decal_chunks = pil % decal_chunks 
     2001        Allocate(member_chuncks(nb_chunks)) 
     2002        member_chuncks = pil % member_chuncks 
     2003 
    14432004        find_list_interp = .true. 
    14442005        exit find_loop 
    … …  
    14542015                                     indmin, indmax, indminglob, indmaxglob,                & 
    14552016                                     pttruetab, cetruetab,                                  & 
    1456                                      memberin, nbdim                                        & 
     2017                                     memberin, nbdim,                                       & 
     2018                                    parentarray_chunk,parentarray_chunk_decal,decal_chunks,  & 
     2019                                    correction_required,member_chuncks,nb_chunks            & 
    14572020#if defined AGRIF_MPI 
    14582021                                    ,indminglob2, indmaxglob2,                              & 
    … …  
    14702033    integer, dimension(nbdim)               :: pttruetab, cetruetab 
    14712034    logical                                 :: memberin 
     2035    integer :: nb_chunks 
     2036    integer, dimension(:,:,:,:), allocatable :: parentarray_chunk 
     2037    integer, dimension(:,:,:,:), allocatable :: parentarray_chunk_decal 
     2038    integer, dimension(:,:),allocatable :: decal_chunks 
     2039    logical, dimension(:),allocatable :: correction_required 
     2040    logical, dimension(:),allocatable :: member_chuncks 
    14722041#if defined AGRIF_MPI 
    14732042    integer, dimension(nbdim,2,2)           :: parentarray 
    … …  
    15182087    pil % cetruetab(1:nbdim) = cetruetab(1:nbdim) 
    15192088 
     2089! chunks 
     2090    pil % nb_chunks = nb_chunks 
     2091    allocate(pil % parentarray_chunk(nb_chunks,nbdim,2,2)) 
     2092    allocate(pil % parentarray_chunk_decal(nb_chunks,nbdim,2,2)) 
     2093    allocate(pil % correction_required(nb_chunks)) 
     2094    allocate(pil % decal_chunks(nb_chunks,nbdim)) 
     2095    allocate(pil % member_chuncks(nb_chunks)) 
     2096 
     2097    pil % parentarray_chunk   = parentarray_chunk 
     2098    pil % parentarray_chunk_decal = parentarray_chunk_decal 
     2099    pil % correction_required = correction_required 
     2100    pil % decal_chunks        = decal_chunks 
     2101    pil % member_chuncks      = member_chuncks 
     2102 
     2103 
    15202104    parcours % suiv => list_interp 
    15212105    list_interp => parcours 

  • vendors/AGRIF/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modinterpbasic.F90

    r5656 r13027  
    220220!CDIR ALTCODE 
    221221!CDIR NODEP 
     222    if (associated(agrif_external_linear_interp)) then 
     223    do i = 1,nc 
     224        y(i)=agrif_external_linear_interp(x(MAX(indparent(i,dir),1)), & 
     225              x(indparent(i,dir)+1),coeffparent(i,dir)) 
     226    enddo 
     227    else 
    222228    do i = 1,nc 
    223229        y(i) = coeffparent(i,dir)  * x(MAX(indparent(i,dir),1)) + & 
    224230           (1.-coeffparent(i,dir)) * x(indparent(i,dir)+1) 
    225231    enddo 
     232    endif 
    226233!--------------------------------------------------------------------------------------------------- 
    227234end subroutine Linear1dAfterCompute 

  • vendors/AGRIF/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modlinktomodel.F90

    r10586 r13027  
    5050        end subroutine alloc_proc 
    5151! 
    52         subroutine typdef_proc ( ) 
     52        subroutine typedef_proc ( ) 
    5353            implicit none 
    54         end subroutine typdef_proc 
     54        end subroutine typedef_proc 
    5555! 
    5656    end interface 
    5757     
    5858    procedure(alloc_proc)   :: Agrif_Allocationcalls 
    59     procedure(typdef_proc) :: Agrif_probdim_modtype_def 
     59    procedure(typedef_proc) :: Agrif_probdim_modtype_def 
    6060! 
    6161end module Agrif_Link 
    … …  
    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/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modmpp.F90

    r5656 r13027  
    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 
    … …  
    190191    pttruetab2(:,Agrif_Procrank) = pttruetab(:,Agrif_Procrank) 
    191192    cetruetab2(:,Agrif_Procrank) = cetruetab(:,Agrif_Procrank) 
     193 
     194        if (agrif_debug_interp) then 
     195            print *,'DANS Get_External_Data_first avec proc : ',Agrif_Procrank 
     196            do k=0,Agrif_Nbprocs-1 
     197                print *,'Processeur ',k 
     198                do i=1,nbdim 
     199                print *,'ptcetretab      = ',i,pttruetab(i,k),cetruetab(i,k) 
     200                print *,'ptcetretabwhole = ',i,pttruetabwhole(i,k),cetruetabwhole(i,k) 
     201               enddo 
     202            enddo 
     203        endif 
    192204! 
    193205    do k = 0,Agrif_Nbprocs-1 
     206        if (agrif_debug_interp) then 
     207            print *,'Proc : ',k 
     208        endif 
    194209    do i = 1,nbdim 
     210        if (agrif_debug_interp) then 
     211            print *,'Direction : ',i 
     212        endif 
    195213        tochangebis = .TRUE. 
    196214        DO i1 = 1,nbdim 
    … …  
    203221            ENDIF 
    204222        ENDDO 
     223        ! Strange CASE 
     224        if ((pttruetab(i,k)>=pttruetab(i,Agrif_Procrank)).AND. & 
     225            (cetruetab(i,k)<=cetruetab(i,Agrif_Procrank))) tochangebis = .FALSE. 
     226 
     227        if (agrif_debug_interp) then 
     228            print *,'tochangebis= ',tochangebis 
     229        endif 
    205230        IF (tochangebis) THEN 
    206231            imin1 = max(pttruetab(i,Agrif_Procrank), pttruetab(i,k)) 
    207232            imax1 = min(cetruetab(i,Agrif_Procrank), cetruetab(i,k)) 
    208233! Always send the most interior points 
    209  
     234        if (agrif_debug_interp) then 
     235            print *,'imin1imax1= ',imin1,imax1 
     236        endif 
    210237            tochange = .false. 
    211238            IF (cetruetab(i,Agrif_Procrank) > cetruetab(i,k)) THEN 
    212239                DO j=imin1,imax1 
    213                     IF ((cetruetab(i,k)-j) > (j-pttruetab(i,Agrif_Procrank))) THEN 
     240                    IF ((bornesmax(i,k)-j) > (j-bornesmin(i,Agrif_Procrank))) THEN 
    214241                        imintmp = j+1 
    215242                        tochange = .TRUE. 
    … …  
    228255            IF (pttruetab(i,Agrif_Procrank) < pttruetab(i,k)) THEN 
    229256                DO j=imax1,imin1,-1 
    230                     IF ((j-pttruetab(i,k)) > (cetruetab(i,Agrif_Procrank)-j)) THEN 
     257                    IF ((j-bornesmin(i,k)) > (bornesmax(i,Agrif_Procrank)-j)) THEN 
    231258                        imaxtmp = j-1 
    232259                        tochange = .TRUE. 
    … …  
    244271    enddo 
    245272 
     273        if (agrif_debug_interp) then 
     274            do k=0,Agrif_Nbprocs-1 
     275                print *,'Processeur ',k 
     276                do i=1,nbdim 
     277                print *,'ptcetretab2      = ',i,pttruetab2(i,k),cetruetab2(i,k) 
     278               enddo 
     279            enddo 
     280        endif 
     281 
    246282    do k = 0,Agrif_NbProcs-1 
    247283! 
    248284        sendtoproc(k) = .true. 
    249285! 
     286        IF ( .not. memberoutall(k) ) THEN 
     287            sendtoproc(k) = .false. 
     288        ELSE 
    250289!CDIR SHORTLOOP 
    251290        do i = 1,nbdim 
    … …  
    257296            endif 
    258297        enddo 
    259         IF ( .not. memberoutall(k) ) THEN 
    260             sendtoproc(k) = .false. 
    261298        ENDIF 
    262299    enddo 
    … …  
    384421    ENDIF 
    385422! 
     423    if (agrif_debug_interp) then 
     424        print *,'PROCESSEUR = ',Agrif_Procrank 
     425        print *,'SENDTOPROC = ',sendtoproc(Agrif_Procrank) 
     426        if (sendtoproc(Agrif_Procrank)) then 
     427            print *,'imin imax = ',imin(:,Agrif_Procrank),imax(:,Agrif_Procrank) 
     428        endif 
     429        endif 
    386430    IF (sendtoproc(Agrif_ProcRank)) THEN 
    387431        call Agrif_var_copy_array(tempCextend,imin(:,Agrif_Procrank),imax(:,Agrif_Procrank), & 

  • vendors/AGRIF/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modtypes.F90

    r12420 r13027  
    2020! 
    2121! 
    22 ! 
     22!  
    2323!> Definition of data types used in AGRIF, of several variables and parameters 
    2424! 
    … …  
    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!> @{ 
    … …  
    153180!> \name Arrays containing the values of the grid variables (character) 
    154181!> @{ 
    155     character(2400)                             :: carray0 
     182    character(4000)                             :: carray0 
    156183    character(:)  ,                 allocatable :: carrayu 
    157     character(200), dimension(:)  , allocatable :: carray1 
    158     character(200), dimension(:,:), allocatable :: carray2 
     184    character(400), dimension(:)  , allocatable :: carray1 
     185    character(400), dimension(:,:), allocatable :: carray2 
    159186!> @} 
    160187!--------------------------------------------------------------------------------------------------- 
    … …  
    219246!> \name Arrays containing the values of the grid variables (logical) 
    220247!> @{ 
    221     logical                                      :: larray0 
     248    logical                                      :: larray0 = .FALSE. 
    222249    logical, dimension(:)          , allocatable :: larray1 
    223250    logical, dimension(:,:)        , allocatable :: larray2 
    … …  
    226253    logical, dimension(:,:,:,:,:)  , allocatable :: larray5 
    227254    logical, dimension(:,:,:,:,:,:), allocatable :: larray6 
    228 !> @} 
     255 
     256!> @} 
     257!> \name Arrays containing the values of the grid variables (logical pointers) 
     258!> @{ 
     259    logical, dimension(:)          , pointer :: plarray1 
     260    logical, dimension(:,:)        , pointer :: plarray2 
     261    logical, dimension(:,:,:)      , pointer :: plarray3 
     262    logical, dimension(:,:,:,:)    , pointer :: plarray4 
     263    logical, dimension(:,:,:,:,:)  , pointer :: plarray5 
     264    logical, dimension(:,:,:,:,:,:), pointer :: plarray6 
     265!> @} 
     266 
    229267!--------------------------------------------------------------------------------------------------- 
    230268end type Agrif_Variable_l 
    … …  
    243281!> \name Arrays containing the values of the grid variables (integer) 
    244282!> @{ 
    245     integer                                      :: iarray0 
     283    integer                                      :: iarray0 = 0 
    246284    integer, dimension(:)          , allocatable :: iarray1 
    247285    integer, dimension(:,:)        , allocatable :: iarray2 
    … …  
    250288    integer, dimension(:,:,:,:,:)  , allocatable :: iarray5 
    251289    integer, dimension(:,:,:,:,:,:), allocatable :: iarray6 
     290 
     291!> @} 
     292! 
     293!> \name Arrays containing the values of the grid variables (integer pointers) 
     294!> @{ 
     295    integer, dimension(:)          , pointer :: piarray1 
     296    integer, dimension(:,:)        , pointer :: piarray2 
     297    integer, dimension(:,:,:)      , pointer :: piarray3 
     298    integer, dimension(:,:,:,:)    , pointer :: piarray4 
     299    integer, dimension(:,:,:,:,:)  , pointer :: piarray5 
     300    integer, dimension(:,:,:,:,:,:), pointer :: piarray6 
    252301!> @} 
    253302!--------------------------------------------------------------------------------------------------- 
    … …  
    274323    logical, dimension(:),    pointer :: sendtoproc2    => NULL() 
    275324    logical, dimension(:),    pointer :: recvfromproc1  => NULL() 
    276     logical, dimension(:),    pointer :: recvfromproc2  => NULL() 
     325    logical, dimension(:),    pointer :: recvfromproc2  => NULL()  
    277326#endif 
     327    integer                           :: nb_chunks 
     328    integer, dimension(:,:,:,:), allocatable :: parentarray_chunk 
     329    integer, dimension(:,:,:,:), allocatable :: parentarray_chunk_decal 
     330    integer, dimension(:,:),allocatable :: decal_chunks 
     331    logical, dimension(:),allocatable :: correction_required 
     332    logical, dimension(:),allocatable :: member_chuncks  
    278333!--------------------------------------------------------------------------------------------------- 
    279334end type Agrif_Interp_Loc 
    … …  
    345400    integer, parameter    :: Agrif_Update_Average = 2           !< average 
    346401    integer, parameter    :: Agrif_Update_Full_Weighting = 3    !< full-weighting 
     402    integer, parameter    :: Agrif_Update_Max = 4               !< Max 
    347403!> @} 
    348404!> \name Raffinement grid switches 
    … …  
    375431    real, dimension(:,:,:,:,:,:), allocatable :: parray6 
    376432! 
    377     logical :: agrif_debug = .false.    ! may be activaded in users subroutine for debugging purposes 
     433    logical :: agrif_debug = .false.        ! may be activaded in users subroutine for debugging purposes 
     434    logical :: agrif_debug_interp = .false. ! may be activaded in users subroutine for debugging interpolations 
     435    logical :: agrif_debug_update = .false. ! may be activaded in users subroutine for debugging updates 
    378436 
    379437! If a grand mother grid is present 
    … …  
    381439    integer, dimension(3) :: coarse_spaceref = (/1,1,1/) 
    382440    integer, dimension(3) :: coarse_timeref  = (/1,1,1/) 
     441     
     442     
     443! External mapping procedure 
     444    Procedure(mapping), pointer :: agrif_external_mapping => NULL() 
     445    abstract interface 
     446     subroutine mapping(ndim,ptx,pty,bounds,bounds_chunks,correction_required,nb_chunks) 
     447     integer :: ndim, ptx, pty 
     448     integer,dimension(ndim,2,2) :: bounds 
     449     integer,dimension(:,:,:,:),allocatable :: bounds_chunks 
     450     logical,dimension(:),allocatable :: correction_required 
     451     integer :: nb_chunks 
     452     end subroutine mapping 
     453    end interface 
     454 
     455    Procedure(linear_interp), pointer :: agrif_external_linear_interp => NULL() 
     456    abstract interface 
     457     real function linear_interp(x1,x2,coeff) 
     458     real :: x1, x2, coeff 
     459     end function linear_interp 
     460    end interface 
    383461! 
    384462contains 

  • vendors/AGRIF/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modupdate.F90

    r5656 r13027  
    279279    real,    dimension(nbdim), intent(in)   :: ds_parent    !< Space steps of the parent grid 
    280280    procedure()                             :: procname     !< Data recovery procedure 
     281    integer, dimension(6)  :: loctab_child      ! Indicates if the child grid has a common border 
     282                                                !    with the root grid 
     283    type(Agrif_Variable), pointer :: root_var   ! Variable on the root grid 
    281284! 
    282285    integer,dimension(nbdim)     :: type_update ! Type of update (copy or average) 
    … …  
    288291    integer                      :: nb, ndir 
    289292    integer :: coeffraf 
    290 ! 
     293    integer :: n 
     294! 
     295    root_var => child % root_var 
     296    loctab_child(1:nbdim) = 0 
     297! 
     298    do n = 1,nbdim 
     299! 
     300        select case(root_var % interptab(n)) 
     301! 
     302        case('x') ! x DIMENSION 
     303! 
     304            if (Agrif_Curgrid % NearRootBorder(1))      loctab_child(n) = -1 
     305            if (Agrif_Curgrid % DistantRootBorder(1))   loctab_child(n) = -2 
     306            if ((Agrif_Curgrid % NearRootBorder(1)) .AND. & 
     307                (Agrif_Curgrid % DistantRootBorder(1))) loctab_child(n) = -3 
     308! 
     309        case('y') ! y DIMENSION 
     310! 
     311            if (Agrif_Curgrid % NearRootBorder(2))      loctab_child(n) = -1 
     312            if (Agrif_Curgrid % DistantRootBorder(2))   loctab_child(n) = -2 
     313            if ((Agrif_Curgrid % NearRootBorder(2)) .AND. & 
     314                (Agrif_Curgrid % DistantRootBorder(2))) loctab_child(n) = -3 
     315! 
     316        case('z') ! z DIMENSION 
     317! 
     318            if (Agrif_Curgrid % NearRootBorder(3))      loctab_child(n) = -1 
     319            if (Agrif_Curgrid % DistantRootBorder(3))   loctab_child(n) = -2 
     320            if ((Agrif_Curgrid % NearRootBorder(3)) .AND. & 
     321                (Agrif_Curgrid % DistantRootBorder(3))) loctab_child(n) = -3 
     322! 
     323        case('N') ! No space DIMENSION 
     324! 
     325            loctab_child(n) = -3 
     326! 
     327        end select 
     328! 
     329    enddo 
     330 
    291331    type_update = child % root_var % type_update(1:nbdim) 
    292332! 
    … …  
    330370        if ( do_update(nb) ) then 
    331371            do ndir = 1,2 
     372              if (loctab_child(nb) /= (-ndir) .AND. loctab_child(nb) /= -3) then 
    332373                ptres(nb,1,ndir,nb) = indtruetab(nb,ndir,1) 
    333374                ptres(nb,2,ndir,nb) = indtruetab(nb,ndir,2) 
    … …  
    348389                    endif 
    349390                enddo 
     391              endif 
    350392            enddo 
    351393        endif 
    … …  
    355397        if ( do_update(nb) ) then 
    356398            do ndir = 1,2 
     399              if (loctab_child(nb) /= (-ndir) .AND. loctab_child(nb) /= -3) then 
    357400                call Agrif_UpdatenD(type_update, parent, child,             & 
    358401                        ptres(1:nbdim,1,ndir,nb),ptres(1:nbdim,2,ndir,nb),  & 
    … …  
    364407#endif 
    365408                        nbdim,procname,nb,ndir) 
     409              endif 
    366410            enddo 
    367411        endif 
    … …  
    390434#endif 
    391435! 
    392     integer, dimension(6),     intent(in)   :: type_update  !< Type of update (copy or average) 
    393436    type(Agrif_Variable), pointer           :: parent       !< Variable of the parent grid 
    394437    type(Agrif_Variable), pointer           :: child        !< Variable of the child grid 
    395438    integer,                   intent(in)   :: nbdim 
     439    integer, dimension(nbdim), intent(in)   :: type_update  !< Type of update (copy or average) 
    396440    integer, dimension(nbdim), intent(in)   :: pttab        !< Index of the first point inside the domain 
    397441    integer, dimension(nbdim), intent(in)   :: petab        !< Index of the first point inside the domain 
    … …  
    423467    logical :: memberin, member 
    424468    integer :: nbin, ndirin 
     469    integer :: i, j,k,l,m 
     470    LOGICAL,DIMENSION(:),ALLOCATABLE :: member_chuncks 
     471    INTEGER,DIMENSION(:,:),ALLOCATABLE :: decal_chunks 
     472    INTEGER :: agrif_external_switch_index 
     473    INTEGER, DIMENSION(2) :: test_orientation 
    425474! 
    426475#if defined AGRIF_MPI 
    427476! 
    428477    integer,dimension(nbdim)    :: indminglob2,indmaxglob2 
     478    INTEGER, DIMENSION(:,:),ALLOCATABLE :: indminglob_chunks, indmaxglob_chunks 
     479    INTEGER, DIMENSION(:,:),ALLOCATABLE :: indminglob2_chunks,indmaxglob2_chunks 
     480    INTEGER, DIMENSION(:,:),ALLOCATABLE :: indminglob3_chunks,indmaxglob3_chunks 
    429481    logical, dimension(0:Agrif_Nbprocs-1) :: sendtoproc1,recvfromproc1 
    430482    logical, dimension(0:Agrif_Nbprocs-1) :: sendtoproc2,recvfromproc2 
    431483    integer                               :: code, local_proc 
    432     integer                               :: i,j,k 
    433484    integer, dimension(nbdim,4)           :: tab3 
    434485    integer, dimension(nbdim,4,0:Agrif_Nbprocs-1) :: tab4 
    … …  
    444495    type(Agrif_Variable), pointer, save :: tempP => NULL()       ! Temporary parent grid variable 
    445496    type(Agrif_Variable), pointer, save :: tempCextend => NULL() ! Temporary child 
     497 
    446498    type(Agrif_Variable), pointer, save :: tempPextend => NULL() ! Temporary parent 
     499    type(Agrif_Variable), pointer, save :: tempPextend_chunk => NULL() ! Temporary parent 
    447500    type(Agrif_Variable), pointer :: tempP_indic, tempP_average 
    448501    type(Agrif_Variable), pointer :: tempC_indic 
    … …  
    450503    real :: coeff_multi 
    451504    integer :: nb_dimensions 
     505 
     506! CHUNK (e.g. periodicity) 
     507 
     508    INTEGER :: nb_chunks 
     509    INTEGER, DIMENSION(:,:,:,:), ALLOCATABLE :: parentarray_chunk 
     510    INTEGER, DIMENSION(:,:,:,:), ALLOCATABLE :: parentarray_chunk_decal 
     511    INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: bounds_chunks 
     512    logical,dimension(:),allocatable :: correction_required 
     513! 
     514 
    452515! 
    453516!   Get local lower and upper bound of the child variable 
    … …  
    459522    coords = child % root_var % coords 
    460523! 
     524 
    461525    call Agrif_Childbounds( nbdim, lowerbound, upperbound, pttab, petab, Agrif_Procrank,    & 
    462526                            coords, pttruetab, cetruetab, memberin ) 
     527 
     528        if (agrif_debug_update) then 
     529        print *,'************CHILDBOUNDS*********************************' 
     530#ifdef AGRIF_MPI 
     531         print *,'Processeur ',Agrif_Procrank 
     532#endif 
     533        print *,'memberin ',memberin 
     534        do i = 1 , nbdim 
     535        print *,'Direction ',i,' indices debut: ',pttab(i),pttruetab(i) 
     536        print *,'Direction ',i,' indices fin  : ',petab(i),cetruetab(i) 
     537        enddo 
     538        print *,'*********************************************' 
     539        endif 
     540 
    463541    call Agrif_Prtbounds( nbdim, indminglob, indmaxglob, s_Parent_temp, s_Child_temp,       & 
    464542                         s_child, ds_child, s_parent, ds_parent,                            & 
    … …  
    469547            ) 
    470548 
     549        if (agrif_debug_update) then 
     550        print *,'************PRTBOUNDS*********************************' 
     551#ifdef AGRIF_MPI 
     552         print *,'Processeur ',Agrif_Procrank 
     553#endif 
     554        do i = 1 , nbdim 
     555        print *,'Direction ',i,' indminglob : ',indminglob(i) 
     556        print *,'Direction ',i,' indmaxglob : ',indmaxglob(i) 
     557        enddo 
     558 
     559        do i = 1 , nbdim 
     560        print *,'Direction ',i,' s_Parent_temp : ',s_Parent_temp(i) 
     561        print *,'Direction ',i,' s_Child_temp  : ',s_Child_temp(i) 
     562        enddo 
     563        print *,'*********************************************' 
     564        endif 
     565 
    471566#if defined AGRIF_MPI 
    472567! 
    … …  
    476571                                       nbdim, Agrif_Procrank, member) 
    477572    ENDIF 
     573 
     574        if (agrif_debug_update) then 
     575        print *,'************GlobalToLocalBounds******************' 
     576#ifdef AGRIF_MPI 
     577         print *,'Processeur ',Agrif_Procrank 
     578#endif 
     579        do i = 1 , nbdim 
     580        print *,'Direction ',i,' childarray global : ',childarray(i,1,1),childarray(i,2,1) 
     581        print *,'Direction ',i,' childarray local  : ',childarray(i,1,2),childarray(i,2,2) 
     582        enddo 
     583 
     584        print *,'*********************************************' 
     585        endif 
    478586 
    479587    call Agrif_Prtbounds(nbdim, indmin, indmax,                     & 
    … …  
    483591                         posvar, type_update, do_update,            & 
    484592                         pttruetabwhole, cetruetabwhole) 
     593 
     594        if (agrif_debug_update) then 
     595        print *,'************PRTBOUNDS II *********************************' 
     596#ifdef AGRIF_MPI 
     597         print *,'Processeur ',Agrif_Procrank 
     598#endif 
     599        do i = 1 , nbdim 
     600        print *,'Direction ',i,' indmin : ',indmin(i) 
     601        print *,'Direction ',i,' indmax : ',indmax(i) 
     602        enddo 
     603 
     604        do i = 1 , nbdim 
     605        print *,'Direction ',i,' s_Parent_temp : ',s_Parent_temp(i) 
     606        print *,'Direction ',i,' s_Child_temp  : ',s_Child_temp(i) 
     607        enddo 
     608        print *,'*********************************************' 
     609        endif 
    485610! 
    486611#else 
    … …  
    582707                                     nbdim, memberinall, coords,                            & 
    583708                                     sendtoproc1,recvfromproc1,                             & 
    584                                      tab4t(:,:,5),tab4t(:,:,6),tab4t(:,:,7),tab4t(:,:,8)) 
     709                                     tab4t(:,:,5),tab4t(:,:,6),tab4t(:,:,7),tab4t(:,:,8),   & 
     710                                     tab4t(:,:,1),tab4t(:,:,2)) 
    585711    endif 
    586712 
    … …  
    610736                                            s_Child_temp(1), s_Parent_temp(1),      & 
    611737                                            ds_child(1), ds_parent(1) ) 
    612                                              
     738 
    613739            IF (Agrif_UseSpecialValueInUpdate) THEN 
    614740            allocate(tempC_indic) 
    … …  
    638764              enddo 
    639765            ENDIF 
    640              
     766 
    641767            WHERE (tempCextend%array1 == Agrif_SpecialValueFineGrid) 
    642768              tempC_indic%array1 = 0. 
    … …  
    644770              tempC_indic%array1 = 1. 
    645771            END WHERE 
    646              
     772 
    647773            Agrif_UseSpecialValueInUpdate = .FALSE. 
    648774            Agrif_Update_Weights = .TRUE. 
    649   
     775 
    650776             call Agrif_Update_1D_Recursive( type_update_temp(1),   & 
    651777                                            tempP_indic%array1,       & 
    … …  
    675801               END WHERE 
    676802            ENDIF 
    677             
     803 
    678804            deallocate(tempP_indic%array1) 
    679805            deallocate(tempC_indic%array1) 
    … …  
    685811            ENDIF 
    686812            ENDIF 
    687              
     813 
    688814        endif 
    689815        if ( nbdim == 2 ) then 
    … …  
    701827            call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array2),ubound(tempCextend%array2),nbdim) 
    702828            call Agrif_array_allocate(tempP_indic,lbound(tempP%array2),ubound(tempP%array2),nbdim) 
    703   
     829 
    704830            compute_average = .FALSE. 
    705831            type_update_temp(1:nbdim) = type_update(1:nbdim) 
    … …  
    723849              enddo 
    724850            ENDIF 
    725              
     851 
    726852            WHERE (tempCextend%array2 == Agrif_SpecialValueFineGrid) 
    727853              tempC_indic%array2 = 0. 
    … …  
    729855              tempC_indic%array2 = 1. 
    730856            END WHERE 
    731              
     857 
    732858            Agrif_UseSpecialValueInUpdate = .FALSE. 
    733859            Agrif_Update_Weights = .TRUE. 
    734              
     860 
    735861            call Agrif_Update_2D_Recursive( type_update_temp(1:2),   & 
    736862                                            tempP_indic%array2,       & 
    … …  
    760886               END WHERE 
    761887            ENDIF 
    762             
     888 
    763889            deallocate(tempP_indic%array2) 
    764890            deallocate(tempC_indic%array2) 
    … …  
    770896            ENDIF 
    771897            ENDIF 
    772              
     898 
    773899        endif 
    774900        if ( nbdim == 3 ) then 
    … …  
    780906                                            s_Child_temp(1:3), s_Parent_temp(1:3),      & 
    781907                                            ds_child(1:3), ds_parent(1:3) ) 
    782                                              
     908 
    783909            IF (Agrif_UseSpecialValueInUpdate) THEN 
    784910            allocate(tempC_indic) 
    … …  
    808934              enddo 
    809935            ENDIF 
    810              
     936 
    811937            WHERE (tempCextend%array3 == Agrif_SpecialValueFineGrid) 
    812938              tempC_indic%array3 = 0. 
    … …  
    814940              tempC_indic%array3 = 1. 
    815941            END WHERE 
    816              
     942 
    817943            Agrif_UseSpecialValueInUpdate = .FALSE. 
    818944            Agrif_Update_Weights = .TRUE. 
    819   
     945 
    820946             call Agrif_Update_3D_Recursive( type_update_temp(1:3),   & 
    821947                                            tempP_indic%array3,       & 
    … …  
    845971               END WHERE 
    846972            ENDIF 
    847             
     973 
    848974            deallocate(tempP_indic%array3) 
    849975            deallocate(tempC_indic%array3) 
    … …  
    855981            ENDIF 
    856982            ENDIF 
    857              
     983 
    858984        endif 
    859985        if ( nbdim == 4 ) then 
    … …  
    865991                                            s_Child_temp(1:4), s_Parent_temp(1:4),      & 
    866992                                            ds_child(1:4), ds_parent(1:4) ) 
    867                                              
     993 
    868994            IF (Agrif_UseSpecialValueInUpdate) THEN 
    869              
     995 
    870996            allocate(tempC_indic) 
    871997            allocate(tempP_indic) 
    872998            call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array4),ubound(tempCextend%array4),nbdim) 
    873999            call Agrif_array_allocate(tempP_indic,lbound(tempP%array4),ubound(tempP%array4),nbdim) 
    874             
     1000 
    8751001            compute_average = .FALSE. 
    8761002            type_update_temp(1:nbdim) = type_update(1:nbdim) 
    … …  
    8941020              enddo 
    8951021            ENDIF 
    896              
     1022 
    8971023            WHERE (tempCextend%array4 == Agrif_SpecialValueFineGrid) 
    8981024              tempC_indic%array4 = 0. 
    … …  
    9001026              tempC_indic%array4 = 1. 
    9011027            END WHERE 
    902              
     1028 
    9031029            Agrif_UseSpecialValueInUpdate = .FALSE. 
    9041030            Agrif_Update_Weights = .TRUE. 
    905   
     1031 
    9061032             call Agrif_Update_4D_Recursive( type_update_temp(1:4),   & 
    9071033                                            tempP_indic%array4,       & 
    … …  
    9141040           Agrif_UseSpecialValueInUpdate = .TRUE. 
    9151041           Agrif_Update_Weights = .FALSE. 
    916             
     1042 
    9171043           IF (compute_average) THEN 
    9181044               WHERE (tempP_indic%array4 == 0.) 
    … …  
    9401066            ENDIF 
    9411067            ENDIF 
    942              
     1068 
    9431069        endif 
    9441070        if ( nbdim == 5 ) then 
    … …  
    9501076                                            s_Child_temp(1:5), s_Parent_temp(1:5),      & 
    9511077                                            ds_child(1:5), ds_parent(1:5) ) 
    952                                              
     1078 
    9531079            IF (Agrif_UseSpecialValueInUpdate) THEN 
    9541080            allocate(tempC_indic) 
    … …  
    9781104              enddo 
    9791105            ENDIF 
    980              
     1106 
    9811107            WHERE (tempCextend%array5 == Agrif_SpecialValueFineGrid) 
    9821108              tempC_indic%array5 = 0. 
    … …  
    9841110              tempC_indic%array5 = 1. 
    9851111            END WHERE 
    986              
     1112 
    9871113            Agrif_UseSpecialValueInUpdate = .FALSE. 
    9881114            Agrif_Update_Weights = .TRUE. 
    989   
     1115 
    9901116             call Agrif_Update_5D_Recursive( type_update_temp(1:5),   & 
    9911117                                            tempP_indic%array5,       & 
    … …  
    10151141               END WHERE 
    10161142            ENDIF 
    1017             
     1143 
    10181144            deallocate(tempP_indic%array5) 
    10191145            deallocate(tempC_indic%array5) 
    … …  
    10251151            ENDIF 
    10261152            ENDIF 
    1027              
     1153 
    10281154        endif 
    10291155        if ( nbdim == 6 ) then 
    … …  
    10801206               END WHERE 
    10811207            ENDIF 
    1082              
     1208 
    10831209            Agrif_UseSpecialValueInUpdate = .FALSE. 
    10841210            Agrif_Update_Weights = .TRUE. 
    1085   
     1211 
    10861212             call Agrif_Update_6D_Recursive( type_update_temp(1:6),   & 
    10871213                                            tempP_indic%array6,       & 
    … …  
    10941220           Agrif_UseSpecialValueInUpdate = .TRUE. 
    10951221           Agrif_Update_Weights = .FALSE. 
    1096             
     1222 
    10971223            WHERE (tempP_indic%array6 == 0.) 
    10981224              tempP%array6 = Agrif_SpecialValueFineGrid 
    … …  
    11001226              tempP%array6 = tempP%array6 /tempP_indic%array6 
    11011227            END WHERE 
    1102             
     1228 
    11031229            deallocate(tempP_indic%array6) 
    11041230            deallocate(tempC_indic%array6) 
    … …  
    11161242    ENDIF 
    11171243 
     1244    if (agrif_debug_update .and. nbdim==2) then 
     1245        print *,'MINMAXUPDATE = ',minval(tempP%array2),maxval(tempP%array2) 
     1246    endif 
     1247 
    11181248#if defined AGRIF_MPI 
    11191249    local_proc = Agrif_Procrank 
    11201250    call Agrif_get_var_bounds_array(parent,lowerbound,upperbound,nbdim) 
    11211251    call Agrif_ChildGrid_to_ParentGrid() 
    1122     call Agrif_Childbounds(nbdim, lowerbound, upperbound,                   & 
    1123                            indminglob,  indmaxglob,  local_proc, coords,    & 
    1124                            indminglob2, indmaxglob2, member) 
    1125 ! 
    1126     IF (member) THEN 
    1127         call Agrif_GlobalToLocalBounds(parentarray, lowerbound, upperbound, & 
    1128                                        indminglob2, indmaxglob2, coords,    & 
    1129                                        nbdim, local_proc, member) 
    1130     ENDIF 
    1131  
    1132     call Agrif_ParentGrid_to_ChildGrid() 
     1252 
     1253          parentarray(:,1,1) = indminglob 
     1254          parentarray(:,2,1) = indmaxglob 
     1255          parentarray(:,1,2) = indminglob 
     1256          parentarray(:,2,2) = indmaxglob 
     1257        if (associated(agrif_external_mapping)) then 
     1258          call agrif_external_mapping(nbdim,child%root_var % posvar(1),child%root_var % posvar(2), & 
     1259                                      parentarray,parentarray_chunk,correction_required,nb_chunks) 
     1260          allocate(decal_chunks(nb_chunks,nbdim)) 
     1261          do i=1,nb_chunks 
     1262            decal_chunks(i,:)=parentarray_chunk(i,:,1,1)-parentarray_chunk(i,:,1,2) 
     1263          enddo 
     1264        else 
     1265            nb_chunks=1 
     1266            allocate(correction_required(nb_chunks)) 
     1267            correction_required=.FALSE. 
     1268            allocate(parentarray_chunk(nb_chunks,nbdim,2,2)) 
     1269            parentarray_chunk(1,:,:,:)=parentarray 
     1270            allocate(decal_chunks(nb_chunks,nbdim)) 
     1271            decal_chunks=0 
     1272        endif 
     1273        if (agrif_debug_update) then 
     1274        print *,'AVANT PARENTCHILDBOUNDS' 
     1275        print *,'nombre de chunks ',nb_chunks 
     1276        do i=1,nb_chunks 
     1277          print *,'CHUNK Number : ',i 
     1278          do j=1,nbdim 
     1279           print *,'Direction ',j 
     1280           print *,'MIN MAX (2) = ',parentarray_chunk(i,j,1,2),parentarray_chunk(i,j,2,2) 
     1281           print *,'MIN MAX (1) = ',parentarray_chunk(i,j,1,1),parentarray_chunk(i,j,2,1) 
     1282          enddo 
     1283        enddo 
     1284        print *,'APRES PARENTCHILDBOUNDS' 
     1285        endif 
     1286 
     1287        allocate(indminglob_chunks(nb_chunks,nbdim)) 
     1288        allocate(indmaxglob_chunks(nb_chunks,nbdim)) 
     1289        allocate(indminglob2_chunks(nb_chunks,nbdim)) 
     1290        allocate(indmaxglob2_chunks(nb_chunks,nbdim)) 
     1291        allocate(indminglob3_chunks(nb_chunks,nbdim)) 
     1292        allocate(indmaxglob3_chunks(nb_chunks,nbdim)) 
     1293        allocate(member_chuncks(nb_chunks)) 
     1294 
     1295        do i=1,nb_chunks 
     1296          indminglob_chunks(i,:) = parentarray_chunk(i,:,1,2) 
     1297          indmaxglob_chunks(i,:) = parentarray_chunk(i,:,2,2) 
     1298        enddo 
     1299 
     1300        do i=1,nb_chunks 
     1301              call Agrif_Childbounds(nbdim,lowerbound,upperbound,         & 
     1302                   indminglob_chunks(i,:),indmaxglob_chunks(i,:), local_proc, coords,   & 
     1303                   indminglob2_chunks(i,:),indmaxglob2_chunks(i,:),member_chuncks(i)) 
     1304        enddo 
     1305 
     1306        if (agrif_debug_update) then 
     1307        print *,'************CHILDBOUNDSPARENTMPI*********************************' 
     1308#ifdef AGRIF_MPI 
     1309         print *,'Processeur ',Agrif_Procrank 
     1310#endif 
     1311        do j=1,nb_chunks 
     1312        print *,'Chunk number ',j 
     1313 
     1314        do i = 1 , nbdim 
     1315        print *,'Direction ',i,' indices debut: ',indminglob_chunks(j,i),indminglob2_chunks(j,i) 
     1316        print *,'Direction ',i,' indices fin  : ',indmaxglob_chunks(j,i),indmaxglob2_chunks(j,i) 
     1317        enddo 
     1318        enddo 
     1319        print *,'*********************************************' 
     1320        endif 
     1321 
     1322        allocate(parentarray_chunk_decal(nb_chunks,nbdim,2,2)) 
     1323        do j=1,nb_chunks 
     1324        if (agrif_debug_update) print *,'CHUNK = ',j 
     1325        if (member_chuncks(j)) then 
     1326            ! call Agrif_GlobalToLocalBounds(parentarray_chunk(j,:,:,:),                               & 
     1327                                           ! lowerbound,  upperbound,                                  & 
     1328                                           ! indminglob2_chunks(j,:), indmaxglob2_chunks(j,:), coords, & 
     1329                                           ! nbdim, local_proc, member_chuncks(j),check_perio=.TRUE.) 
     1330 
     1331            call Agrif_GlobalToLocalBounds(parentarray_chunk(j,:,:,:),                               & 
     1332                                           lowerbound,  upperbound,                                  & 
     1333                                           indminglob2_chunks(j,:), indmaxglob2_chunks(j,:), coords, & 
     1334                                           nbdim, local_proc, member_chuncks(j)) 
     1335 
     1336            if (correction_required(j)) then 
     1337                do i=1,2 
     1338                    test_orientation(1)=agrif_external_switch_index(child%root_var % posvar(1),child%root_var % posvar(2), & 
     1339                    parentarray_chunk(j,i,1,1),i) 
     1340                    test_orientation(2)=agrif_external_switch_index(child%root_var % posvar(1),child%root_var % posvar(2), & 
     1341                    parentarray_chunk(j,i,2,1),i) 
     1342                    parentarray_chunk_decal(j,i,1,1)=minval(test_orientation) 
     1343                    parentarray_chunk_decal(j,i,2,1)=maxval(test_orientation) 
     1344                enddo 
     1345                do i=3,nbdim 
     1346                  parentarray_chunk_decal(j,i,:,1) = parentarray_chunk(j,i,:,1)+decal_chunks(j,i) 
     1347                enddo 
     1348            else 
     1349            do i=1,nbdim 
     1350            parentarray_chunk_decal(j,i,:,1) = parentarray_chunk(j,i,:,1)+decal_chunks(j,i) 
     1351            enddo 
     1352            endif 
     1353 
     1354            if (agrif_debug_update) then 
     1355            do i=1,nbdim 
     1356            print *,'parentarray = ',i,parentarray_chunk(j,i,1,1),parentarray_chunk(j,i,2,1), & 
     1357                parentarray_chunk(j,i,1,2),parentarray_chunk(j,i,2,2) 
     1358                print *,'parentarraydecal = ',i,parentarray_chunk_decal(j,i,1,1),parentarray_chunk_decal(j,i,2,1) 
     1359            enddo 
     1360            endif 
     1361        endif 
     1362        enddo 
     1363 
     1364!     call Agrif_Childbounds(nbdim, lowerbound, upperbound,                   & 
     1365!                            indminglob,  indmaxglob,  local_proc, coords,    & 
     1366!                            indminglob2, indmaxglob2, member) 
     1367 
     1368!         if (agrif_debug_update) then 
     1369!         print *,'************CHILDBOUNDS PARENT*********************************' 
     1370! #ifdef AGRIF_MPI 
     1371!          print *,'Processeur ',Agrif_Procrank 
     1372! #endif 
     1373!         print *,'member ',member 
     1374!         do i = 1 , nbdim 
     1375!         print *,'Direction ',i,' indminglob2 : ',indminglob2(i) 
     1376!         print *,'Direction ',i,' indmaxglob2 : ',indmaxglob2(i) 
     1377!         enddo 
     1378!         print *,'*********************************************' 
     1379!         endif 
     1380! 
     1381!     IF (member) THEN 
     1382!         call Agrif_GlobalToLocalBounds(parentarray, lowerbound, upperbound, & 
     1383!                                        indminglob2, indmaxglob2, coords,    & 
     1384!                                        nbdim, local_proc, member,check_perio=.TRUE.) 
     1385!     ENDIF 
     1386 
     1387!         if (agrif_debug_update) then 
     1388!         print *,'************GlobalToLocalBounds II******************' 
     1389! #ifdef AGRIF_MPI 
     1390!          print *,'Processeur ',Agrif_Procrank 
     1391! #endif 
     1392!         do i = 1 , nbdim 
     1393!         print *,'Direction ',i,' parentarray global : ',parentarray(i,1,1),parentarray(i,2,1) 
     1394!         print *,'Direction ',i,' parentarray local  : ',parentarray(i,1,2),parentarray(i,2,2) 
     1395!         enddo 
     1396 
     1397!         print *,'*********************************************' 
     1398!         endif 
     1399 
     1400 
     1401        parentarray(:,1,:)=Huge(1) 
     1402        parentarray(:,2,:)=-Huge(1) 
     1403        indminglob2=Huge(1) 
     1404        indmaxglob2=-Huge(1) 
     1405        member = .FALSE. 
     1406        do j=1,nb_chunks 
     1407          if (member_chuncks(j)) then 
     1408            do i=1,nbdim 
     1409             parentarray(i,1,1) = min(parentarray(i,1,1),parentarray_chunk_decal(j,i,1,1)) 
     1410             parentarray(i,1,2) = min(parentarray(i,1,2),parentarray_chunk(j,i,1,2)) 
     1411             parentarray(i,2,1) = max(parentarray(i,2,1),parentarray_chunk_decal(j,i,2,1)) 
     1412             parentarray(i,2,2) = max(parentarray(i,2,2),parentarray_chunk(j,i,2,2)) 
     1413            enddo 
     1414 
     1415            if (correction_required(j)) then 
     1416                do i=1,2 
     1417                    test_orientation(1)=agrif_external_switch_index(child%root_var % posvar(1),child%root_var % posvar(2), & 
     1418                    indminglob2_chunks(j,i),i) 
     1419                    test_orientation(2)=agrif_external_switch_index(child%root_var % posvar(1),child%root_var % posvar(2), & 
     1420                    indmaxglob2_chunks(j,i),i) 
     1421                    indminglob2(i)=min(indminglob2(i),minval(test_orientation)) 
     1422                    indmaxglob2(i)=max(indmaxglob2(i),maxval(test_orientation)) 
     1423                enddo 
     1424 
     1425                do i=3,nbdim 
     1426             indminglob2(i)=min(indminglob2(i),indminglob2_chunks(j,i)+decal_chunks(j,i)) 
     1427             indmaxglob2(i)=max(indmaxglob2(i),indmaxglob2_chunks(j,i)+decal_chunks(j,i)) 
     1428                enddo 
     1429            else 
     1430                           do i=1,nbdim 
     1431             indminglob2(i)=min(indminglob2(i),indminglob2_chunks(j,i)+decal_chunks(j,i)) 
     1432             indmaxglob2(i)=max(indmaxglob2(i),indmaxglob2_chunks(j,i)+decal_chunks(j,i)) 
     1433                         enddo 
     1434         endif 
     1435 
     1436            member = .TRUE. 
     1437          endif 
     1438        enddo 
     1439 
     1440        call Agrif_ParentGrid_to_ChildGrid() 
     1441 
     1442        if (agrif_debug_update) then 
     1443        print *,'************ FINAL PARENTARRAY *****************' 
     1444#ifdef AGRIF_MPI 
     1445        print *,'Processeur ',Agrif_Procrank,' MEMBER = ',member 
     1446        do i=1,nbdim 
     1447         print *,'Direction ',i,' indices debut = ',parentarray(i,1,1),parentarray(i,1,2) 
     1448         print *,'Direction ',i,' indices fin = ',parentarray(i,2,1),parentarray(i,2,2) 
     1449        enddo 
     1450#endif 
     1451        endif 
     1452 
     1453        if (agrif_debug_update) then 
     1454        print *,'************ FINAL INDMINGLOB *****************' 
     1455#ifdef AGRIF_MPI 
     1456        print *,'Processeur ',Agrif_Procrank,' MEMBER = ',member 
     1457        do i=1,nbdim 
     1458         print *,'Direction ',i,' indices debut = ',indminglob2(i) 
     1459         print *,'Direction ',i,' indices fin = ',indmaxglob2(i) 
     1460        enddo 
     1461#endif 
     1462        endif 
    11331463 
    11341464    if (.not.find_list_update) then 
    … …  
    11541484                                     nbdim, memberinall2, coords,                           & 
    11551485                                     sendtoproc2, recvfromproc2,                            & 
    1156                                      tab5t(:,:,5),tab5t(:,:,6),tab5t(:,:,7),tab5t(:,:,8)) 
     1486                                     tab5t(:,:,5),tab5t(:,:,6),tab5t(:,:,7),tab5t(:,:,8),   & 
     1487                                     tab5t(:,:,1),tab5t(:,:,2)) 
    11571488 
    11581489        call Agrif_Addto_list_update(child%list_update,pttab,petab,lb_child,lb_parent,      & 
    … …  
    11711502    parentarray(:,1,2) = indmin 
    11721503    parentarray(:,2,2) = indmax 
     1504 
     1505        if (associated(agrif_external_mapping)) then 
     1506          call Agrif_ChildGrid_to_ParentGrid() 
     1507          call agrif_external_mapping(nbdim,child%root_var % posvar(1),child%root_var % posvar(2), & 
     1508                                      parentarray,parentarray_chunk,correction_required,nb_chunks) 
     1509          call Agrif_ParentGrid_to_ChildGrid() 
     1510          allocate(decal_chunks(nb_chunks,nbdim)) 
     1511          do i=1,nb_chunks 
     1512            decal_chunks(i,:)=parentarray_chunk(i,:,1,1)-parentarray_chunk(i,:,1,2) 
     1513          enddo 
     1514        else 
     1515            nb_chunks=1 
     1516            allocate(correction_required(nb_chunks)) 
     1517            correction_required=.FALSE. 
     1518            allocate(parentarray_chunk(nb_chunks,nbdim,2,2)) 
     1519            parentarray_chunk(1,:,:,:)=parentarray 
     1520        endif 
     1521        if (agrif_debug_update) then 
     1522        print *,'AVANT PARENTCHILDBOUNDS' 
     1523        print *,'nombre de chunks ',nb_chunks 
     1524        do i=1,nb_chunks 
     1525          print *,'CHUNK Number : ',i 
     1526          do j=1,nbdim 
     1527           print *,'Direction ',j 
     1528           print *,'MIN MAX (2) = ',parentarray_chunk(i,j,1,2),parentarray_chunk(i,j,2,2) 
     1529           print *,'MIN MAX (1) = ',parentarray_chunk(i,j,1,1),parentarray_chunk(i,j,2,1) 
     1530          enddo 
     1531        enddo 
     1532        print *,'APRES PARENTCHILDBOUNDS' 
     1533        endif 
     1534        allocate(member_chuncks(nb_chunks)) 
     1535        allocate(parentarray_chunk_decal(nb_chunks,nbdim,2,2)) 
     1536        member_chuncks = .TRUE. 
     1537        member = .TRUE. 
     1538        do j=1,nb_chunks 
     1539        if (agrif_debug_update) print *,'CHUNK = ',j 
     1540        if (member_chuncks(j)) then 
     1541            do i=1,nbdim 
     1542            parentarray_chunk_decal(j,i,:,1) = parentarray_chunk(j,i,:,1)   !+decal_chunks(j,i) 
     1543            enddo 
     1544            if (agrif_debug_update) then 
     1545            do i=1,nbdim 
     1546            print *,'parentarray = ',i,parentarray_chunk(j,i,1,1),parentarray_chunk(j,i,2,1), & 
     1547                parentarray_chunk(j,i,1,2),parentarray_chunk(j,i,2,2) 
     1548                print *,'parentarraydecal = ',i,parentarray_chunk_decal(j,i,1,1),parentarray_chunk_decal(j,i,2,1) 
     1549            enddo 
     1550            endif 
     1551        endif 
     1552        enddo 
     1553 
    11731554    member = .TRUE. 
    11741555#endif 
     1556 
     1557        if (agrif_debug_update .and. nbdim==2) then 
     1558        print *,'MINMAXUPDATEEXTND = ',minval(tempPextend%array2),maxval(tempPextend%array2) 
     1559    endif 
    11751560! 
    11761561!   Special values on the child grid 
    … …  
    12301615    endif 
    12311616! 
    1232     IF (member) THEN 
     1617 
    12331618 
    12341619        call Agrif_ChildGrid_to_ParentGrid() 
     1620 
     1621        if (nb_chunks > 1) then 
     1622            allocate(tempPextend_chunk) 
     1623            SELECT CASE(nbdim) 
     1624            CASE(1) 
     1625                call Agrif_array_allocate(tempPextend_chunk,lbound(tempPextend%array1),ubound(tempPextend%array1),nbdim) 
     1626            CASE(2) 
     1627                call Agrif_array_allocate(tempPextend_chunk,lbound(tempPextend%array2),ubound(tempPextend%array2),nbdim) 
     1628            CASE(3) 
     1629                call Agrif_array_allocate(tempPextend_chunk,lbound(tempPextend%array3),ubound(tempPextend%array3),nbdim) 
     1630            CASE(4) 
     1631                call Agrif_array_allocate(tempPextend_chunk,lbound(tempPextend%array4),ubound(tempPextend%array4),nbdim) 
     1632            CASE(5) 
     1633                call Agrif_array_allocate(tempPextend_chunk,lbound(tempPextend%array5),ubound(tempPextend%array5),nbdim) 
     1634            CASE(6) 
     1635                call Agrif_array_allocate(tempPextend_chunk,lbound(tempPextend%array6),ubound(tempPextend%array6),nbdim) 
     1636            END SELECT 
     1637        else 
     1638            tempPextend_chunk => tempPextend 
     1639        endif 
     1640 
     1641        do i=1,nb_chunks 
     1642 
     1643        if (member_chuncks(i)) then 
     1644 
     1645            if (nb_chunks > 1) then 
     1646                call Agrif_var_copy_array (tempPextend_chunk, parentarray_chunk_decal(i,:,1,1), parentarray_chunk_decal(i,:,2,1), & 
     1647                                           tempPextend, parentarray_chunk_decal(i,:,1,1), parentarray_chunk_decal(i,:,2,1), nbdim ) 
     1648            endif 
    12351649! 
    12361650        SELECT CASE(nbdim) 
    12371651        CASE(1) 
    1238             call procname( tempPextend % array1(            & 
    1239                     parentarray(1,1,1):parentarray(1,2,1)), & 
    1240                     parentarray(1,1,2),parentarray(1,2,2),.FALSE.,nbin,ndirin) 
     1652            ! call procname( tempPextend % array1(            & 
     1653            !         parentarray(1,1,1):parentarray(1,2,1)), & 
     1654            !         parentarray(1,1,2),parentarray(1,2,2),.FALSE.,nbin,ndirin) 
     1655 
     1656            call procname(tempPextend_chunk%array1(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1)),         & 
     1657                      parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2),.FALSE.,nbin,ndirin) 
     1658 
    12411659        CASE(2) 
    1242             call procname( tempPextend % array2(            & 
    1243                     parentarray(1,1,1):parentarray(1,2,1),  & 
    1244                     parentarray(2,1,1):parentarray(2,2,1)), & 
    1245                     parentarray(1,1,2),parentarray(1,2,2),  & 
    1246                     parentarray(2,1,2),parentarray(2,2,2),.FALSE.,nbin,ndirin) 
     1660 
     1661            if (correction_required(i)) then 
     1662              call correct_field(tempPextend_chunk%array2(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 
     1663                      parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1)), & 
     1664                      parentarray_chunk_decal(i,1,1,1),parentarray_chunk_decal(i,1,2,1), & 
     1665                      parentarray_chunk_decal(i,2,1,1),parentarray_chunk_decal(i,2,2,1)) 
     1666            endif 
     1667 
     1668            call procname(tempPextend_chunk%array2(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 
     1669                      parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1)),         & 
     1670                      parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2),    & 
     1671                      parentarray_chunk(i,2,1,2),parentarray_chunk(i,2,2,2),.FALSE.,nbin,ndirin) 
     1672 
    12471673        CASE(3) 
    1248             call procname( tempPextend % array3(            & 
    1249                     parentarray(1,1,1):parentarray(1,2,1),  & 
    1250                     parentarray(2,1,1):parentarray(2,2,1),  & 
    1251                     parentarray(3,1,1):parentarray(3,2,1)), & 
    1252                     parentarray(1,1,2),parentarray(1,2,2),  & 
    1253                     parentarray(2,1,2),parentarray(2,2,2),  & 
    1254                     parentarray(3,1,2),parentarray(3,2,2),.FALSE.,nbin,ndirin) 
     1674 
     1675            if (correction_required(i)) then 
     1676                do k=parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2) 
     1677              call correct_field(tempPextend_chunk%array3(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 
     1678                      parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1),k), & 
     1679                      parentarray_chunk_decal(i,1,1,1),parentarray_chunk_decal(i,1,2,1), & 
     1680                      parentarray_chunk_decal(i,2,1,1),parentarray_chunk_decal(i,2,2,1)) 
     1681                enddo 
     1682            endif 
     1683 
     1684            call procname(tempPextend_chunk%array3(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 
     1685                      parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1), & 
     1686                      parentarray_chunk_decal(i,3,1,1):parentarray_chunk_decal(i,3,2,1)),         & 
     1687                      parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2),    & 
     1688                      parentarray_chunk(i,2,1,2),parentarray_chunk(i,2,2,2),    & 
     1689                      parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2),.FALSE.,nbin,ndirin) 
     1690 
     1691 
     1692 
     1693 
    12551694        CASE(4) 
    1256             call procname( tempPextend % array4(            & 
    1257                     parentarray(1,1,1):parentarray(1,2,1),  & 
    1258                     parentarray(2,1,1):parentarray(2,2,1),  & 
    1259                     parentarray(3,1,1):parentarray(3,2,1),  & 
    1260                     parentarray(4,1,1):parentarray(4,2,1)), & 
    1261                     parentarray(1,1,2),parentarray(1,2,2),  & 
    1262                     parentarray(2,1,2),parentarray(2,2,2),  & 
    1263                     parentarray(3,1,2),parentarray(3,2,2),  & 
    1264                     parentarray(4,1,2),parentarray(4,2,2),.FALSE.,nbin,ndirin) 
     1695 
     1696            if (correction_required(i)) then 
     1697                do l=parentarray_chunk(i,4,1,2),parentarray_chunk(i,4,2,2) 
     1698                do k=parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2) 
     1699              call correct_field(tempPextend_chunk%array4(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 
     1700                      parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1),k,l), & 
     1701                      parentarray_chunk_decal(i,1,1,1),parentarray_chunk_decal(i,1,2,1), & 
     1702                      parentarray_chunk_decal(i,2,1,1),parentarray_chunk_decal(i,2,2,1)) 
     1703                enddo 
     1704            enddo 
     1705            endif 
     1706 
     1707            call procname(tempPextend_chunk%array4(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 
     1708                      parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1), & 
     1709                      parentarray_chunk_decal(i,3,1,1):parentarray_chunk_decal(i,3,2,1), & 
     1710                      parentarray_chunk_decal(i,4,1,1):parentarray_chunk_decal(i,4,2,1)),         & 
     1711                      parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2),    & 
     1712                      parentarray_chunk(i,2,1,2),parentarray_chunk(i,2,2,2),    & 
     1713                      parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2),    & 
     1714                      parentarray_chunk(i,4,1,2),parentarray_chunk(i,4,2,2),.FALSE.,nbin,ndirin) 
     1715 
    12651716        CASE(5) 
    1266             call procname( tempPextend % array5(            & 
    1267                     parentarray(1,1,1):parentarray(1,2,1),  & 
    1268                     parentarray(2,1,1):parentarray(2,2,1),  & 
    1269                     parentarray(3,1,1):parentarray(3,2,1),  & 
    1270                     parentarray(4,1,1):parentarray(4,2,1),  & 
    1271                     parentarray(5,1,1):parentarray(5,2,1)), & 
    1272                     parentarray(1,1,2),parentarray(1,2,2),  & 
    1273                     parentarray(2,1,2),parentarray(2,2,2),  & 
    1274                     parentarray(3,1,2),parentarray(3,2,2),  & 
    1275                     parentarray(4,1,2),parentarray(4,2,2),  & 
    1276                     parentarray(5,1,2),parentarray(5,2,2),.FALSE.,nbin,ndirin) 
     1717 
     1718            if (correction_required(i)) then 
     1719                do m=parentarray_chunk(i,5,1,2),parentarray_chunk(i,5,2,2) 
     1720                do l=parentarray_chunk(i,4,1,2),parentarray_chunk(i,4,2,2) 
     1721                do k=parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2) 
     1722              call correct_field(tempPextend_chunk%array5(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 
     1723                      parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1),k,l,m), & 
     1724                      parentarray_chunk_decal(i,1,1,1),parentarray_chunk_decal(i,1,2,1), & 
     1725                      parentarray_chunk_decal(i,2,1,1),parentarray_chunk_decal(i,2,2,1)) 
     1726                enddo 
     1727            enddo 
     1728            enddo 
     1729            endif 
     1730 
     1731            call procname(tempPextend_chunk%array5(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 
     1732                      parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1), & 
     1733                      parentarray_chunk_decal(i,3,1,1):parentarray_chunk_decal(i,3,2,1), & 
     1734                      parentarray_chunk_decal(i,4,1,1):parentarray_chunk_decal(i,4,2,1), & 
     1735                      parentarray_chunk_decal(i,5,1,1):parentarray_chunk_decal(i,5,2,1)),         & 
     1736                      parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2),    & 
     1737                      parentarray_chunk(i,2,1,2),parentarray_chunk(i,2,2,2),    & 
     1738                      parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2),    & 
     1739                      parentarray_chunk(i,4,1,2),parentarray_chunk(i,4,2,2),    & 
     1740                      parentarray_chunk(i,5,1,2),parentarray_chunk(i,5,2,2),.FALSE.,nbin,ndirin) 
     1741 
    12771742        CASE(6) 
    1278             call procname( tempPextend % array6(            & 
    1279                     parentarray(1,1,1):parentarray(1,2,1),  & 
    1280                     parentarray(2,1,1):parentarray(2,2,1),  & 
    1281                     parentarray(3,1,1):parentarray(3,2,1),  & 
    1282                     parentarray(4,1,1):parentarray(4,2,1),  & 
    1283                     parentarray(5,1,1):parentarray(5,2,1),  & 
    1284                     parentarray(6,1,1):parentarray(6,2,1)), & 
    1285                     parentarray(1,1,2),parentarray(1,2,2),  & 
    1286                     parentarray(2,1,2),parentarray(2,2,2),  & 
    1287                     parentarray(3,1,2),parentarray(3,2,2),  & 
    1288                     parentarray(4,1,2),parentarray(4,2,2),  & 
    1289                     parentarray(5,1,2),parentarray(5,2,2),  & 
    1290                     parentarray(6,1,2),parentarray(6,2,2),.FALSE.,nbin,ndirin) 
     1743 
     1744            call procname(tempPextend_chunk%array6(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 
     1745                      parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1), & 
     1746                      parentarray_chunk_decal(i,3,1,1):parentarray_chunk_decal(i,3,2,1), & 
     1747                      parentarray_chunk_decal(i,4,1,1):parentarray_chunk_decal(i,4,2,1), & 
     1748                      parentarray_chunk_decal(i,5,1,1):parentarray_chunk_decal(i,5,2,1), & 
     1749                      parentarray_chunk_decal(i,6,1,1):parentarray_chunk_decal(i,6,2,1)),         & 
     1750                      parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2),    & 
     1751                      parentarray_chunk(i,2,1,2),parentarray_chunk(i,2,2,2),    & 
     1752                      parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2),    & 
     1753                      parentarray_chunk(i,4,1,2),parentarray_chunk(i,4,2,2),    & 
     1754                      parentarray_chunk(i,5,1,2),parentarray_chunk(i,5,2,2),& 
     1755                      parentarray_chunk(i,6,1,2),parentarray_chunk(i,6,2,2),.FALSE.,nbin,ndirin) 
     1756 
    12911757        END SELECT 
     1758        ENDIF 
     1759        enddo ! enddo i=1,nb_chunks 
     1760 
     1761        if (nb_chunks > 1) then 
     1762            call Agrif_array_deallocate(tempPextend_chunk,nbdim) 
     1763            deallocate(tempPextend_chunk) 
     1764        endif 
    12921765! 
    12931766        call Agrif_ParentGrid_to_ChildGrid() 
    12941767! 
    1295         call Agrif_array_deallocate(tempPextend,nbdim) 
    1296 ! 
    1297     ENDIF 
     1768        if (ANY(member_chuncks)) call Agrif_array_deallocate(tempPextend,nbdim) 
     1769! 
     1770 
    12981771! 
    12991772#if defined AGRIF_MPI 
    … …  
    13551828        IF ( do_update(i) ) THEN 
    13561829            IF (posvar(i) == 1) THEN 
    1357                 IF      (type_update(i) == Agrif_Update_Average) THEN 
     1830                IF ((type_update(i) == Agrif_Update_Average).OR.(type_update(i) == Agrif_Update_Max)) THEN 
    13581831                    positionmin = positionmin - ds_parent(i)/2. 
    13591832                ELSE IF (type_update(i) == Agrif_Update_Full_Weighting) THEN 
    … …  
    13811854        IF ( do_update(i) ) THEN 
    13821855            IF (posvar(i) == 1) THEN 
    1383                 IF      (type_update(i) == Agrif_Update_Average) THEN 
     1856                IF ((type_update(i) == Agrif_Update_Average).OR.(type_update(i) == Agrif_Update_Max)) THEN 
    13841857                    positionmax = positionmax  + ds_parent(i)/2. 
    13851858                ELSE IF (type_update(i) == Agrif_Update_Full_Weighting) THEN 
    … …  
    20072480                    ds_parent, ds_child ) 
    20082481! 
     2482    elseif ( type_update == Agrif_Update_Max ) then 
     2483! 
     2484        call Agrif_basicupdate_max1d(           & 
     2485                    parent_tab, child_tab,          & 
     2486                    np,         nc,                 & 
     2487                     s_parent,  s_child,            & 
     2488                    ds_parent, ds_child ) 
    20092489    elseif ( type_update == Agrif_Update_Full_Weighting ) then 
    20102490! 

  • vendors/AGRIF/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modupdatebasic.F90

    r5656 r13027  
    220220end subroutine Agrif_basicupdate_average1d 
    221221!=================================================================================================== 
     222 
     223!=================================================================================================== 
     224!  subroutine Agrif_basicupdate_max1d 
     225! 
     226!> Carries out an update by taking the maximum on a parent grid (vector x)from its child grid (vector y). 
     227!--------------------------------------------------------------------------------------------------- 
     228subroutine Agrif_basicupdate_max1d ( x, y, np, nc, s_parent, s_child, ds_parent, ds_child ) 
     229!--------------------------------------------------------------------------------------------------- 
     230    REAL, DIMENSION(np), intent(out)    :: x 
     231    REAL, DIMENSION(nc), intent(in)     :: y 
     232    INTEGER,             intent(in)     :: np,nc 
     233    REAL,                intent(in)     :: s_parent,  s_child 
     234    REAL,                intent(in)     :: ds_parent, ds_child 
     235! 
     236    INTEGER :: i, ii, locind_child_left, coeffraf 
     237    REAL    :: xpos, invcoeffraf 
     238    INTEGER :: nbnonnuls 
     239    INTEGER :: diffmod 
     240! 
     241    coeffraf = nint(ds_parent/ds_child) 
     242    invcoeffraf = 1./coeffraf 
     243! 
     244    if (coeffraf == 1) then 
     245        locind_child_left = 1 + nint((s_parent - s_child)/ds_child) 
     246        x(1:np) = y(locind_child_left:locind_child_left+np-1) 
     247        return 
     248    endif 
     249! 
     250    xpos = s_parent 
     251    x = -HUGE(1.0) 
     252! 
     253    diffmod = 0 
     254! 
     255    IF ( mod(coeffraf,2) == 0 ) diffmod = 1 
     256! 
     257    locind_child_left = 1 + agrif_int((xpos - s_child)/ds_child) 
     258! 
     259    IF (Agrif_UseSpecialValueInUpdate) THEN 
     260        do i = 1,np 
     261            nbnonnuls = 0 
     262!CDIR NOVECTOR 
     263            do ii = -coeffraf/2+locind_child_left+diffmod, & 
     264                     coeffraf/2+locind_child_left 
     265                IF (y(ii) /= Agrif_SpecialValueFineGrid) THEN 
     266                    x(i) = max(x(i),y(ii)) 
     267                ENDIF 
     268            enddo 
     269            locind_child_left = locind_child_left + coeffraf 
     270        enddo 
     271    ELSE 
     272! 
     273!CDIR ALTCODE 
     274        do i = 1,np 
     275!CDIR NOVECTOR 
     276            do ii = -coeffraf/2+locind_child_left+diffmod, & 
     277                     coeffraf/2+locind_child_left 
     278                x(i) = max(x(i),y(ii)) 
     279            enddo 
     280            locind_child_left = locind_child_left + coeffraf 
     281        enddo 
     282    ENDIF 
     283!--------------------------------------------------------------------------------------------------- 
     284end subroutine Agrif_basicupdate_max1d 
     285!=================================================================================================== 
     286 
    222287! 
    223288!=================================================================================================== 

  • vendors/AGRIF/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modutil.F90

    r12420 r13027  
    108108!--------------------------------------------------------------------------------------------------- 
    109109end subroutine Agrif_Step_Child 
     110!=================================================================================================== 
     111! 
     112!=================================================================================================== 
     113!  subroutine Agrif_Step_Childs 
     114! 
     115!> Apply 'procname' to each child grids of the current grid 
     116!--------------------------------------------------------------------------------------------------- 
     117!     ************************************************************************** 
     118!!!   Subroutine Agrif_Step_Childs 
     119!     ************************************************************************** 
     120! 
     121      Subroutine Agrif_Step_Childs(procname) 
     122! 
     123    procedure(step_proc)    :: procname     !< subroutine to call on each grid 
     124!     Pointer argument 
     125      Type(Agrif_Grid),pointer   :: g        ! Pointer on the current grid 
     126! 
     127 
     128! 
     129!     Local pointer 
     130      Type(Agrif_pgrid),pointer  :: parcours ! Pointer for the recursive 
     131                                             ! procedure 
     132! 
     133      g => Agrif_Curgrid 
     134       
     135      parcours => g % child_list % first 
     136! 
     137!     Recursive procedure for the time integration of the grid hierarchy       
     138      Do while (associated(parcours)) 
     139! 
     140!       Instanciation of the variables of the current grid 
     141        Call Agrif_Instance(parcours % gr) 
     142 
     143!     One step on the current grid 
     144 
     145         Call procname () 
     146        parcours => parcours % next 
     147      enddo 
     148    
     149      If (associated(g % child_list % first)) Call Agrif_Instance (g) 
     150      Return 
     151      End Subroutine Agrif_Step_Childs 
    110152!=================================================================================================== 
    111153! 
    … …  
    538580!=================================================================================================== 
    539581! 
     582!=================================================================================================== 
     583! 
    540584! 
    541585!=================================================================================================== 
    … …  
    587631#ifdef AGRIF_MPI 
    588632    else 
    589 #endif     
    590633! Continue only if the grid has defined sequences of child integrations. 
    591634    if ( .not. associated(save_grid % child_seq) ) return 
    … …  
    610653! 
    611654    enddo 
    612 #ifdef AGRIF_MPI 
    613655    endif 
    614656#endif  
    … …  
    700742subroutine Agrif_Init_Grids ( procname1, procname2 ) 
    701743!--------------------------------------------------------------------------------------------------- 
    702     procedure(typdef_proc), optional   :: procname1 !< (Default: Agrif_probdim_modtype_def) 
     744    procedure(typedef_proc), optional   :: procname1 !< (Default: Agrif_probdim_modtype_def) 
    703745    procedure(alloc_proc),   optional   :: procname2 !< (Default: Agrif_Allocationcalls) 
    704746! 
    … …  
    717759    nunit = Agrif_Get_Unit() 
    718760    open(nunit, file='AGRIF_FixedGrids.in', form='formatted', status="old", ERR=98) 
    719     if (Agrif_Probdim == 3) then 
    720        read(nunit,*) is_coarse, rhox, rhoy, rhoz, rhot 
    721     elseif (Agrif_Probdim == 2) then 
    722        read(nunit,*) is_coarse, rhox, rhoy, rhot 
    723     elseif (Agrif_Probdim == 2) then 
    724        read(nunit,*) is_coarse, rhox, rhot 
    725     endif 
     761    read(nunit,*) is_coarse 
    726762    if (is_coarse == -1) then 
    727763       agrif_coarse = .TRUE. 
     764       rewind(nunit) 
    728765       if (Agrif_Probdim == 3) then 
     766          read(nunit,*) is_coarse, rhox, rhoy, rhoz, rhot 
    729767          coarse_spaceref(1:3)=(/rhox,rhoy,rhoz/) 
    730768       elseif (Agrif_Probdim == 2) then 
     769          read(nunit,*) is_coarse, rhox, rhoy, rhot 
    731770          coarse_spaceref(1:2)=(/rhox,rhoy/) 
    732        elseif (Agrif_Probdim == 2) then 
     771       elseif (Agrif_Probdim == 1) then 
     772          read(nunit,*) is_coarse, rhox, rhot 
    733773          coarse_spaceref(1:1)=(/rhox/) 
    734774       endif 

  • vendors/AGRIF/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modvariables.F90

    r5656 r13027  
    9999    Agrif_Curgrid % Nbvariables = Agrif_Curgrid % Nbvariables + 1 
    100100 
    101     varid = -Agrif_Curgrid % Nbvariables 
     101    varid = Agrif_Curgrid % Nbvariables 
    102102 
    103103    var % parent_var => Agrif_Search_Variable(Agrif_Curgrid % parent, Agrif_Curgrid % nbvariables) 

  • vendors/AGRIF/dev_r12970_AGRIF_CMEMS/LEX/Makefile.lex

    r9140 r13027  
    11LEX      = flex -i 
    2 YACC  = bison -t -v -g 
     2YACC  = /usr/bin/bison -t -v -g --graph 
     3#YACC = byacc -t -v 
    34 
    45all: main.c fortran.c 
    56 
    67main.c : convert.tab.c convert.yy.c 
    7    cat   convert.tab.c convert.yy.c > ../LIB/main.c 
     8   cat   convert.tab.c convert.yy.c > main.c 
    89   $(RM) convert.tab.c convert.yy.c 
    910 
    1011fortran.c : fortran.tab.c fortran.yy.c 
    11    cat   fortran.tab.c fortran.yy.c > ../LIB/fortran.c 
     12   cat   fortran.tab.c fortran.yy.c > fortran.c 
    1213   $(RM) fortran.tab.c fortran.yy.c 
    1314 
    … …  
    2930 
    3031clean-all: clean 
    31    $(RM) ../LIB/main.c ../LIB/fortran.c 
     32   $(RM) main.c fortran.c 

  • vendors/AGRIF/dev_r12970_AGRIF_CMEMS/LEX/convert.y

    r9140 r13027  
    130130    int infreegiven ; 
    131131    int infixedgiven ; 
    132     int lengthmainfile; 
    133132 
    134133    char filetoparse[LONG_FNAME]; 
    … …  
    160159    tmpuselocallist = (listusemodule *) NULL; 
    161160    List_ContainsSubroutine = (listnom *) NULL; 
     161    List_Do_labels = (listname *) NULL; 
    162162    oldfortran_out = (FILE *) NULL; 
    163163 
    164     if (argc < 2) print_usage(); 
    165      
     164    if ( argc < 2 ) 
     165        print_usage(); 
     166 
    166167    strcpy(config_file, argv[1]); 
    167168    strcpy(work_dir, "."); 
    … …  
    257258            strcpy(filetoparse, argv[i+1]); 
    258259            i++; 
    259             lengthmainfile = strlen(filetoparse); 
    260             if (!strcasecmp(&filetoparse[lengthmainfile-4], ".f90")) 
    261             { 
    262                 infixed = 0; 
    263                 infree = 1; 
    264             } 
    265             else 
    266             { 
    267                 infixed = 1; 
    268                 infree = 0; 
    269             } 
     260            infree  = (strstr(filetoparse, ".f90") != NULL) || (strstr(filetoparse, ".F90") != NULL); 
     261            infixed = ! infree; 
    270262        } 
    271263        else if (!strcasecmp(argv[i], "-free")) 
    … …  
    400392    /* Build new subroutines                                                   */ 
    401393    firstpass = 0; 
     394    /* 
     395    printf("**********************************\n"); 
     396    printf("SECOND PASSES \n"); 
     397    printf("**********************************\n"); 
     398    */ 
    402399    process_fortran(filetoparse); 
    403400 

  • vendors/AGRIF/dev_r12970_AGRIF_CMEMS/LEX/fortran.lex

    r9140 r13027  
    3939%s character 
    4040%x donottreat 
     41%x donottreat_interface 
     42%x includestate 
    4143%s fortran77style 
    4244%s fortran90style 
    … …  
    4749extern FILE * yyin; 
    4850#define MAX_INCLUDE_DEPTH 30 
     51#define YY_BUF_SIZE 64000 
    4952YY_BUFFER_STATE include_stack[MAX_INCLUDE_DEPTH]; 
    50 int line_num_input = 1; 
     53int line_num_input = 0; 
    5154int newlinef90 = 0; 
    52 char tmpc; 
    53 #define PRINT_LINE_NUM()     // { fprintf(stderr,"== Parsing l.%4d...\n", line_num_input); } 
    54 #define INCREMENT_LINE_NUM() { line_num_input++; PRINT_LINE_NUM(); } 
    55  
    56 /******************************************************************************/ 
    57 /**************PETITS PB NON PREVUS *******************************************/ 
    58 /******************************************************************************/ 
    59 /* NEXTLINF77 un ligne fortran 77 peut commencer par -      &a=b or on        */ 
    60 /*            a prevu seulement       & a=b avec l'espace entre le symbole    */ 
    61 /*            de la 7eme et le debut de la ligne de commande                  */ 
    62 /*            le ! est aussi interdit comme symbole de la 7 eme colonne       */ 
    63 /*            Normalement NEXTLINEF77 \n+[ ]{5}[^ ]                           */ 
    64 /******************************************************************************/ 
    65 #define YY_USER_ACTION  if (firstpass == 0) ECHO; 
     55int tmpc; 
     56 
     57int lastwasendofstmt = 1; 
     58 
     59extern char linebuf1[1024]; 
     60extern char linebuf2[1024]; 
     61 
     62int count_newlines(const char* str_in) 
     63{ 
     64    int k, i = 0; 
     65    for( k=0 ; k<strlen(str_in) ; k++) 
     66        if (str_in[k] == '\n') i++; 
     67    return i; 
     68} 
     69 
     70#define PRINT_LINE_NUM()   //  { fprintf(stderr,"== Parsing l.%4d...\n", line_num_input); } 
     71#define INCREMENT_LINE_NUM() { line_num_input+=count_newlines(fortran_text) ; PRINT_LINE_NUM(); } 
     72#define YY_USER_ACTION       { if (increment_nbtokens !=0) token_since_endofstmt++; increment_nbtokens = 1; if (token_since_endofstmt>=1) lastwasendofstmt=0; /*printf("VALLIJSDFLSD = %d %d %s \n",lastwasendofstmt,token_since_endofstmt,fortran_text); */ if (firstpass) { strcpy(linebuf1, linebuf2); strncpy(linebuf2, fortran_text,80);} \ 
     73                               else {my_position_before=setposcur();/*printf("muposition = %d\n",my_position_before);*/ECHO;} } 
     74#define YY_BREAK {/*printf("VALL = %d %d\n",lastwasendofstmt,token_since_endofstmt);*/if (token_since_endofstmt>=1) lastwasendofstmt=0; break;} 
    6675 
    6776void out_of_donottreat(void); 
    … …  
    6978%} 
    7079 
    71 REAL8 "real*8"[ \t]*"(a-h,o-z)" 
    72  
    7380SLASH       "/" 
    74 DSLASH      "/"[ \t]*"/" 
    7581HEXA        Z\'[0-9a-fA-F]+\' 
    76 NAME        [a-zA-Z\_][a-zA-Z0-9\_]* 
    7782INTEGER     [0-9]+ 
    78  
     83NAME        [a-zA-Z][a-zA-Z0-9\_]* 
    7984EXPONENT    [edq][-+]?{INTEGER} 
    8085 
    81 BEG_DNT         ^[C!]"$AGRIF_DO_NOT_TREAT"[ \t]*\n 
    82 END_DNT         ^[C!]"$AGRIF_END_DO_NOT_TREAT"[ \t]*\n 
     86BEG_DNT         ^[C!]"$AGRIF_DO_NOT_TREAT"[ \t]*([ \t\n]*(!.*\n)*)+\n 
     87END_DNT         ^[C!]"$AGRIF_END_DO_NOT_TREAT"[ \t]*([ \t\n]*(!.*\n)*)+\n 
    8388 
    8489BEG_INTERFACE   ^[ \t]*interface 
    … …  
    8792ASSIGNTYPE      "assignment"[ \t]*"("[ \t]*[-+=]+[ \t]*")" 
    8893 
    89 COMM_F77        ^([Cc*](([ \t]*\n)|([^AaHhOo\n].*\n))) 
    90 COMM_F90        ^[ \t]*!.*\n 
     94COMM_F77        ^[c*].*\n 
     95COMM_F90_1      ^([ \t\n]*(!.*\n)*)+\n 
    9196COMM_F90_2      !.* 
    92 NEXTLINEF90     "&".*\n+ 
    93 NEXTLINEF77     [\n \t]*\n[ \t]{5}("&"|"+"|"$"|"*"|"1"|"2"|"3"|"4"|"5"|"6"|"7"|"8"|"9"|"."|"#") 
    94  
    95 LABEL           ^(((" "|[0-9]){1,5})|([ \t]{1,5}))[ &]+ 
     97NEXTLINEF90     &([ \t\n]|(!.*\n))* 
     98NEXTLINEF77     \n(([c*].*\n)|(([ \t]{0,4}|[ \t]{6,})!.*\n)|[\n])*[ ]{5}([a-z0-9&+$*.#/!;]) 
     99LABEL           ^[ 0-9]{1,5}[ \t]+ 
    96100 
    97101%% 
    … …  
    99103  if (infree)  BEGIN(fortran90style) ; 
    100104 
    101 {REAL8}                     { return TOK_REAL8; } 
    102105subroutine                  { return TOK_SUBROUTINE; } 
    103106program                     { return TOK_PROGRAM; } 
    104107allocate                    { inallocate = 1; return TOK_ALLOCATE; } 
     108continue                    { return TOK_CONTINUE; } 
    105109nullify                    { return TOK_NULLIFY; } 
    106 null[ ]*\([ ]*\)            { return TOK_NULL_PTR; } 
    107110deallocate                  { inallocate = 1; return TOK_DEALLOCATE; } 
    108111result                      { return TOK_RESULT; } 
    109112function                    { return TOK_FUNCTION; } 
    110 end[ \t]*program            { strcpy(yylval.na,fortran_text); return TOK_ENDPROGRAM;} 
    111 end[ \t]*module             { strcpy(yylval.na,fortran_text); return TOK_ENDMODULE; } 
    112 end[ \t]*subroutine         { strcpy(yylval.na,fortran_text); return TOK_ENDSUBROUTINE;} 
    113 end[ \t]*function           { strcpy(yylval.na,fortran_text); return TOK_ENDFUNCTION;} 
    114113end                         { strcpy(yylval.na,fortran_text); return TOK_ENDUNIT;} 
    115 include                     { pos_curinclude = setposcur()-9; return TOK_INCLUDE;} 
    116 ^[ \t]*use[ ]+              { strcpy(yylval.na,fortran_text); 
    117                               tmpc = (char) input(); unput(tmpc); 
    118                               if ( ( tmpc >= 'a' && tmpc <= 'z' ) || 
    119                                    ( tmpc >= 'A' && tmpc <= 'Z' )  )  return TOK_USE; 
    120                               else                                    return TOK_NAME; 
    121                             } 
     114include                     { pos_curinclude = setposcur()-9; BEGIN(includestate); } 
     115use                         { return TOK_USE;} 
    122116rewind                      { return TOK_REWIND; } 
    123117implicit                    { return TOK_IMPLICIT; } 
    124118none                        { return TOK_NONE; } 
    125119call                        { return TOK_CALL; } 
    126 .true.                      { return TOK_TRUE; } 
    127 .false.                     { return TOK_FALSE; } 
     120.true.                      { strcpy(yylval.na,fortran_text); return TOK_TRUE; } 
     121.false.                     { strcpy(yylval.na,fortran_text); return TOK_FALSE; } 
    128122\=\>                        { return TOK_POINT_TO; } 
    129123{ASSIGNTYPE}                { strcpy(yylval.na,fortran_text); return TOK_ASSIGNTYPE;} 
    130124\*\*                        { strcpy(yylval.na,fortran_text); return TOK_DASTER; } 
    131 \.[ \t]*eqv\.               { strcpy(yylval.na,fortran_text); return TOK_EQV; } 
    132 \.[ \t]*eq\.                { strcpy(yylval.na,fortran_text); return TOK_EQ;  } 
    133 \.[ \t]*gt\.                { strcpy(yylval.na,fortran_text); return TOK_GT;  } 
    134 \.[ \t]*ge\.                { strcpy(yylval.na,fortran_text); return TOK_GE;  } 
    135 \.[ \t]*lt\.                { strcpy(yylval.na,fortran_text); return TOK_LT;  } 
    136 \.[ \t]*le\.                { strcpy(yylval.na,fortran_text); return TOK_LE;  } 
    137 \.[ \t]*neqv\.              { strcpy(yylval.na,fortran_text); return TOK_NEQV;} 
    138 \.[ \t]*ne\.                { strcpy(yylval.na,fortran_text); return TOK_NE;  } 
    139 \.[ \t]*not\.               { strcpy(yylval.na,fortran_text); return TOK_NOT; } 
    140 \.[ \t]*or\.                { strcpy(yylval.na,fortran_text); return TOK_OR;  } 
     125\.eqv\.               { strcpy(yylval.na,fortran_text); return TOK_EQV; } 
     126\.[ \t]*eq[ \t]*\.                { strcpy(yylval.na,fortran_text); return TOK_EQ;  } 
     127\.gt\.                { strcpy(yylval.na,fortran_text); return TOK_GT;  } 
     128\.ge\.                { strcpy(yylval.na,fortran_text); return TOK_GE;  } 
     129\.lt\.                { strcpy(yylval.na,fortran_text); return TOK_LT;  } 
     130\.le\.                { strcpy(yylval.na,fortran_text); return TOK_LE;  } 
     131\.neqv\.              { strcpy(yylval.na,fortran_text); return TOK_NEQV;} 
     132\.[ \t]*ne[ \t]*\.                { strcpy(yylval.na,fortran_text); return TOK_NE;  } 
     133\.not\.               { strcpy(yylval.na,fortran_text); return TOK_NOT; } 
     134\.or\.                { strcpy(yylval.na,fortran_text); return TOK_OR;  } 
    141135\.[ \t]*xor\.               { strcpy(yylval.na,fortran_text); return TOK_XOR; } 
    142 \.[ \t]*and\.               { strcpy(yylval.na,fortran_text); return TOK_AND; } 
     136\.and\.               { strcpy(yylval.na,fortran_text); return TOK_AND; } 
     137\=\=                  { strcpy(yylval.na,fortran_text); return TOK_EQUALEQUAL; } 
     138\/\=                  { strcpy(yylval.na,fortran_text); return TOK_SLASHEQUAL; } 
     139\<\=                  { strcpy(yylval.na,fortran_text); return TOK_INFEQUAL; } 
     140\>\=                  { strcpy(yylval.na,fortran_text); return TOK_SUPEQUAL; } 
    143141module                      { return TOK_MODULE; } 
    144142while                       { return TOK_WHILE; } 
    145143concurrent                  { return TOK_CONCURRENT; } 
    146144end[ \t]*do                 { return TOK_ENDDO; } 
    147 do                          { return TOK_PLAINDO;} 
     145do[\ t]+{INTEGER}           { strcpy(yylval.na,&fortran_text[2]); 
     146                              if (testandextractfromlist(&List_Do_labels,&fortran_text[2]) == 1) 
     147                              { 
     148                              return TOK_PLAINDO_LABEL_DJVIEW; 
     149                              } 
     150                              else 
     151                              { 
     152                              List_Do_labels=Insertname(List_Do_labels,yylval.na,1); 
     153                              return TOK_PLAINDO_LABEL; 
     154                             } 
     155                             } 
     156do                          { increment_nbtokens = 0; return TOK_PLAINDO;} 
    148157real                        { strcpy(yylval.na,fortran_text); return TOK_REAL; } 
    149158integer                     { strcpy(yylval.na,fortran_text); return TOK_INTEGER; } 
    … …  
    153162double[ \t]*precision       { strcpy(yylval.na,fortran_text); return TOK_DOUBLEPRECISION; } 
    154163double[ \t]*complex         { strcpy(yylval.na,fortran_text); return TOK_DOUBLECOMPLEX; } 
    155 complex                     { return TOK_COMPLEX; } 
     164complex                     { strcpy(yylval.na,fortran_text); return TOK_COMPLEX; } 
    156165allocatable                 { return TOK_ALLOCATABLE; } 
    157166close                       { return TOK_CLOSE; } 
    … …  
    172181^[ \t]*global[ \t]+         { return TOK_GLOBAL; } 
    173182external                    { return TOK_EXTERNAL; } 
    174 intent                      { return TOK_INTENT; } 
     183intent                      { intent_spec = 1; return TOK_INTENT; } 
    175184pointer                     { return TOK_POINTER; } 
    176185optional                    { return TOK_OPTIONAL; } 
    177186save                        { return TOK_SAVE; } 
    178 ^[ \t]*type[ \t]*\(         { pos_cur_decl = setposcur()-5; return TOK_TYPEPAR; } 
    179 ^[ \t]*type[ \t\,]+         { return TOK_TYPE; } 
     187^[ \t]*type[ \t]*\(         { pos_cur_decl = setposcur()-strlen(fortran_text); return TOK_TYPEPAR; } 
     188^[ \t]*type/[ \t\,:]+       { return TOK_TYPE; } 
    180189end[ \t]*type               { return TOK_ENDTYPE; } 
    181190stat                        { if (inallocate == 1) return TOK_STAT; else { strcpy(yylval.na,fortran_text); return TOK_NAME; } } 
    182191open                        { return TOK_OPEN; } 
    183192return                      { return TOK_RETURN; } 
    184 exit[^(]                    { return TOK_EXIT; } 
     193exit                        { return TOK_EXIT; } 
    185194print                       { return TOK_PRINT; } 
    186195module[ \t]*procedure       { return TOK_PROCEDURE; } 
     196read[ \t]*\(                { in_io_control_spec = 1; return TOK_READ_PAR; } 
    187197read                        { return TOK_READ; } 
    188198namelist                    { return TOK_NAMELIST; } 
     199write[ \t]*\(               { in_io_control_spec = 1; return TOK_WRITE_PAR; } 
    189200write                       { return TOK_WRITE; } 
    190 flush                       { return TOK_FLUSH; } 
     201flush                       { strcpy(yylval.na,fortran_text); return TOK_FLUSH; } 
    191202target                      { return TOK_TARGET; } 
    192203public                      { return TOK_PUBLIC; } 
    193204private                     { return TOK_PRIVATE; } 
    194 in                          { strcpy(yylval.na,fortran_text); return TOK_IN; } 
    195 ^[ \t]*data[ \t]+           { pos_curdata = setposcur()-strlen(fortran_text); Init_List_Data_Var(); return TOK_DATA; } 
    196 continue                    { return TOK_CONTINUE; } 
     205in                          { strcpy(yylval.na,fortran_text); 
     206                               if (intent_spec==1) 
     207                                {return TOK_IN; } 
     208                              else 
     209                              { 
     210                              return TOK_NAME; 
     211                              } 
     212                            } 
     213^[ \t]*data[ \t]+           { pos_curdata = setposcur()-strlen(fortran_text); /*Init_List_Data_Var();*/ return TOK_DATA; } 
    197214go[ \t]*to                  { return TOK_PLAINGOTO; } 
    198 out                         { strcpy(yylval.na,fortran_text); return TOK_OUT; } 
    199 inout                       { strcpy(yylval.na,fortran_text); return TOK_INOUT; } 
     215out                         { strcpy(yylval.na,fortran_text); 
     216                               if (intent_spec==1) 
     217                                {return TOK_OUT; } 
     218                              else 
     219                              { 
     220                              return TOK_NAME; 
     221                              } 
     222                            } 
     223inout                       { strcpy(yylval.na,fortran_text); 
     224                               if (intent_spec==1) 
     225                                {return TOK_IN; } 
     226                              else 
     227                              { 
     228                              return TOK_INOUT; 
     229                              } 
     230                            } 
    200231intrinsic                   { return TOK_INTRINSIC; } 
    201232then                        { return TOK_THEN; } 
    … …  
    203234else                        { return TOK_ELSE; } 
    204235end[ \t]*if                 { return TOK_ENDIF; } 
    205 if                          { return TOK_LOGICALIF; } 
    206 sum[ \t]*\(                 { return TOK_SUM; } 
    207 max[ \t]*\(                 { return TOK_MAX; } 
    208 tanh                        { return TOK_TANH; } 
    209 maxval                      { return TOK_MAXVAL; } 
    210 trim                        { return TOK_TRIM; } 
    211 sqrt\(                      { return TOK_SQRT; } 
     236if[ \t]*\(/(.*\)[ \t]*[\=|\+|\-]+.*\))   {strcpy(yylval.na,fortran_text); 
     237                            return TOK_LOGICALIF_PAR; 
     238                            } 
     239if/([ \t]*\([^(]*\)[ \t]*[\=|\+|\-]+)   {strcpy(yylval.na,fortran_text); 
     240                            return TOK_NAME; 
     241                            } 
     242if[ \t]*\(                 {strcpy(yylval.na,fortran_text); 
     243                            return TOK_LOGICALIF_PAR; 
     244                            } 
    212245select[ \t]*case            { return TOK_SELECTCASE; } 
    213 ^[ \t]*case[ \t]*           { return TOK_CASE; } 
     246^[ \t]*case[ \t]*           { if (in_select_case_stmt > 0) return TOK_CASE ; else return TOK_NAME;} 
    214247default                     { return TOK_DEFAULT; } 
    215248end[ \t]*select             { return TOK_ENDSELECT; } 
    216249file[ \t]*\=                { return TOK_FILE; } 
     250access[ \t]*\=                { return TOK_ACCESS; } 
     251action[ \t]*\=                { return TOK_ACTION; } 
     252iolength[ \t]*\=                { return TOK_IOLENGTH; } 
    217253unit[ \t]*\=                { return TOK_UNIT; } 
     254opened[ \t]*\=                { return TOK_OPENED; } 
    218255fmt[ \t]*\=                 { return TOK_FMT; } 
    219256nml[ \t]*\=                 { return TOK_NML; } 
    220257end[ \t]*\=                 { return TOK_END; } 
    221258eor[ \t]*\=                 { return TOK_EOR; } 
     259len/([ \t]*\=)                 { 
     260                            if (in_char_selector ==1) 
     261                               return TOK_LEN; 
     262                            else 
     263                            { 
     264                            strcpy(yylval.na,fortran_text); return TOK_NAME; 
     265                            } 
     266                            } 
     267kind/([ \t]*\=)            { 
     268                            if ((in_char_selector==1) || (in_kind_selector == 1)) 
     269                               return TOK_KIND; 
     270                            else 
     271                            { 
     272                            strcpy(yylval.na,fortran_text); return TOK_NAME; 
     273                            } 
     274                            } 
     275errmsg[ \t]*\=              { return TOK_ERRMSG; } 
     276mold[ \t]*\=              { return TOK_MOLD; } 
     277source[ \t]*\=              { return TOK_SOURCE; } 
     278position[ \t]*\=            { return TOK_POSITION; } 
     279iomsg[ \t]*\=               { return TOK_IOMSG; } 
     280iostat[ \t]*\=              { return TOK_IOSTAT; } 
    222281err[ \t]*\=                 { return TOK_ERR; } 
     282form[ \t]*\=                { return TOK_FORM; } 
     283name/([ \t]*\=)             { 
     284                            if (in_inquire==1) 
     285                               return TOK_NAME_EQ; 
     286                            else 
     287                            { 
     288                            strcpy(yylval.na,fortran_text); return TOK_NAME; 
     289                            } 
     290                            } 
     291recl[ \t]*\=                { return TOK_RECL; } 
     292rec/([ \t]*\=)              { if (in_io_control_spec == 1) 
     293                              return TOK_REC; 
     294                             else 
     295                             { 
     296                             strcpy(yylval.na,fortran_text); return TOK_NAME; 
     297                             } 
     298                             } 
     299status/([ \t]*\=)           { if (close_or_connect == 1) 
     300                              return TOK_STATUS; 
     301                             else 
     302                             { 
     303                             strcpy(yylval.na,fortran_text); return TOK_NAME; 
     304                             } 
     305                             } 
     306status                      { strcpy(yylval.na,fortran_text); return TOK_NAME;} 
    223307exist[ \t]*\=               { return TOK_EXIST; } 
    224 min[ \t]*\(                 { return TOK_MIN; } 
    225 nint                        { return TOK_NINT; } 
    226 float                       { return TOK_FLOAT; } 
    227 exp                         { return TOK_EXP; } 
    228 cos                         { return TOK_COS; } 
    229 cosh                        { return TOK_COSH; } 
    230 acos                        { return TOK_ACOS; } 
    231 sin                         { return TOK_SIN; } 
    232 sinh                        { return TOK_SINH; } 
    233 asin                        { return TOK_ASIN; } 
    234 log                         { return TOK_LOG; } 
    235 tan                         { return TOK_TAN; } 
    236 atan                        { return TOK_ATAN; } 
    237308cycle                       { return TOK_CYCLE; } 
    238 abs[ \t]*\(                 { return TOK_ABS; } 
    239 mod                         { return TOK_MOD; } 
    240 sign[ \t]*\(                { return TOK_SIGN; } 
    241 minloc                      { return TOK_MINLOC; } 
    242 maxloc                      { return TOK_MAXLOC; } 
    243 minval                      { return TOK_MINVAL; } 
    244309backspace                   { return TOK_BACKSPACE; } 
    245310::                          { return TOK_FOURDOTS;  } 
     311\/[ \t]*({NEXTLINEF90}|{NEXTLINEF77})*[ \t]*\/  { strcpy(yylval.na,fortran_text); return TOK_DSLASH; } 
    246312\({SLASH}                   { return TOK_LEFTAB; } 
    247313{SLASH}\)                   { return TOK_RIGHTAB; } 
    248 format[ \t]*\((.|{NEXTLINEF90}|{NEXTLINEF77})*\)  { 
    249                               return TOK_FORMAT; } 
    250314{SLASH}                     { strcpy(yylval.na,fortran_text); return TOK_SLASH; } 
    251 DSLASH                      { strcpy(yylval.na,fortran_text); return TOK_DSLASH; } 
    252 (\')[^']*&{0,1}\n[ \t]*&{0,1}[^']*(\') { 
    253                               strcpy(yylval.na,fortran_text); return TOK_CHAR_CUT; } 
    254 (\')[^']*(\')             { strcpy(yylval.na,fortran_text);return TOK_CHAR_CONSTANT; } 
    255 (\")[^"]*(\")             { strcpy(yylval.na,fortran_text);return TOK_CHAR_MESSAGE; } 
    256 {BEG_INTERFACE}             { BEGIN(donottreat); } 
    257 <donottreat>{END_INTERFACE} { out_of_donottreat(); return '\n'; } 
     315((\')[^']*&{0,1}\n[ \t]*&{0,1}[^']*(\'))+ { 
     316                              INCREMENT_LINE_NUM() ; strcpy(yylval.na,fortran_text); return TOK_CHAR_CUT; } 
     317<includestate>((\')[^']*(\'))+ {Add_Include_1(fortran_text);} 
     318<includestate>[ \t]* {} 
     319<includestate>\n { 
     320                  if (inmoduledeclare == 0 ) 
     321                  { 
     322                  pos_end=setposcur(); 
     323                  RemoveWordSET_0(fortran_out,pos_curinclude,pos_end-pos_curinclude); 
     324                  } 
     325                  out_of_donottreat(); 
     326                  } 
     327((\')[^']*(\'))+               { strcpy(yylval.na,fortran_text);return TOK_CHAR_CONSTANT; } 
     328((\")[^"]*(\"))+               { strcpy(yylval.na,fortran_text);return TOK_CHAR_MESSAGE; } 
     329{BEG_INTERFACE}             { BEGIN(donottreat_interface); } 
     330<donottreat_interface>{END_INTERFACE} { out_of_donottreat(); return '\n'; } 
     331<donottreat_interface>.*\n            {INCREMENT_LINE_NUM() ; } 
     332<fortran77style>{NAME}{NEXTLINEF77}[a-zA-Z0-9\_]+ {strcpy(yylval.na,fortran_text); removenewline(yylval.na); 
     333                            return TOK_NAME; } 
    258334{NAME}                      { strcpy(yylval.na,fortran_text); return TOK_NAME; } 
     335{INTEGER}\.[0-9]+           {strcpy(yylval.na,fortran_text); return TOK_CSTREAL; } 
    259336({INTEGER}\.[0-9]*)/[^"and."|"false."|"true."|"eq."|"or."|"gt."|"ge."|"lt."|"le."|"not."|"ne."] {  // REAL1 
    260337                              strcpy(yylval.na,fortran_text); return TOK_CSTREAL; } 
    261338(({INTEGER}\.[0-9]+|[0-9]*\.{INTEGER}){EXPONENT}?)|{INTEGER}(\.)?{EXPONENT}                     {  // REAL2 
    262339                              strcpy(yylval.na,fortran_text); return TOK_CSTREAL; } 
    263 {INTEGER}                   { strcpy(yylval.na,fortran_text); return TOK_CSTINT; } 
     340{INTEGER}                   { strcpy(yylval.na,fortran_text); 
     341                             if (lastwasendofstmt == 0) 
     342                              return TOK_CSTINT; 
     343                             else 
     344                              if (testandextractfromlist(&List_Do_labels,fortran_text) == 1) 
     345                              { 
     346                              removefromlist(&List_Do_labels,yylval.na); 
     347                              return TOK_LABEL_DJVIEW; 
     348                              } 
     349                              else 
     350                              { 
     351                              return TOK_LABEL; 
     352                              } 
     353                             } 
    264354\$                          {} 
    265355\.                          {} 
    266 \(|\)|:|\[|\]|\+|\-|\*      { strcpy(yylval.na,fortran_text); return (int) *fortran_text; } 
     356\(/([ \t]*[\+\-]?[a-zA-Z0-9]+[\.]*[0-9]*(\_({INTEGER}|{NAME}))?[ \t]*\,[ \t]*[\+\-]?[a-zA-Z0-9]+[\.]*[0-9]*(\_({INTEGER}|{NAME}))?[ \t]*\)) { 
     357                            in_complex_literal = -1; 
     358                            return (int) *fortran_text; 
     359                            } 
     360\(|\)|:|\[|\]|\+|\-|\*|\_   { strcpy(yylval.na,fortran_text); return (int) *fortran_text; } 
    267361\%                          { strcpy(yylval.na,fortran_text); return (int) *fortran_text; } 
    268 \;                          { return TOK_SEMICOLON; } 
    269 \,                          { return (int) *fortran_text; } 
     362\;                          { lastwasendofstmt=1; token_since_endofstmt = 0; return TOK_SEMICOLON; } 
     363\,                          { if (in_complex_literal==-1) {return TOK_COMMACOMPLEX; in_complex_literal=0;} else; return (int) *fortran_text; } 
    270364\=                          { return (int) *fortran_text; } 
    271365\<                          { return (int) *fortran_text; } 
    272366\>                          { return (int) *fortran_text; } 
    273 \n                          { INCREMENT_LINE_NUM() ; return '\n'; } 
    274 ^[ ]*$                      {} 
    275 [ \t]+                      {} 
    276 {LABEL}                     { if (newlinef90 == 0) return TOK_LABEL; else newlinef90 = 0; } 
     367\n                          { INCREMENT_LINE_NUM() ; lastwasendofstmt=1; token_since_endofstmt = 0; increment_nbtokens = 0; return '\n'; } 
     368[ \t]+                      {increment_nbtokens = 0;} 
     369<fortran77style>{LABEL}[ \t]*format[ \t]*\((.|{NEXTLINEF90}|{NEXTLINEF77})*\)  { 
     370                              return TOK_LABEL_FORMAT; } 
     371<fortran90style>^[ \t]*{INTEGER}[ \t]*format[ \t]*\((.|{NEXTLINEF90})*\) {return TOK_LABEL_FORMAT; } 
    277372{NEXTLINEF90}               { INCREMENT_LINE_NUM() ; newlinef90=1; } 
    278 {NEXTLINEF77}               { INCREMENT_LINE_NUM() ; } 
    279  
    280 {BEG_DNT}                   { INCREMENT_LINE_NUM() ; BEGIN(donottreat); } 
    281 <donottreat>{END_DNT}       { out_of_donottreat(); return '\n'; } 
    282 <donottreat>.*\n            { INCREMENT_LINE_NUM() ; } 
    283 <fortran77style>{COMM_F77}  { INCREMENT_LINE_NUM() ; } 
    284 {COMM_F90}                  { INCREMENT_LINE_NUM() ; } 
    285 {COMM_F90_2}                {} 
     373<fortran77style>{NEXTLINEF77}               { INCREMENT_LINE_NUM() ;} 
     374 
     375{BEG_DNT}                   {INCREMENT_LINE_NUM() ; BEGIN(donottreat); } 
     376<donottreat>{END_DNT}       {out_of_donottreat(); return '\n'; } 
     377<donottreat>.*\n            {INCREMENT_LINE_NUM() ; } 
     378<fortran77style>{COMM_F77}  {INCREMENT_LINE_NUM() ; increment_nbtokens = 0;} 
     379{COMM_F90_1}                {INCREMENT_LINE_NUM() ; increment_nbtokens = 0;} 
     380{COMM_F90_2}                {increment_nbtokens = 0;} 
     381<<EOF>>                     {endoffile = 1; yyterminate();} 
    286382%% 
    287383 

  • vendors/AGRIF/dev_r12970_AGRIF_CMEMS/LEX/fortran.y

    r12420 r13027  
    4242 
    4343extern int line_num_input; 
    44 extern char *fortran_text; 
    4544 
    4645char c_selectorname[LONG_M]; 
    … …  
    5049int c_selectorgiven=0; 
    5150listvar *curlistvar; 
     51int in_select_case_stmt=0; 
    5252typedim c_selectordim; 
    5353listcouple *coupletmp; 
    5454int removeline=0; 
     55int token_since_endofstmt = 0; 
     56int increment_nbtokens = 1; 
     57int in_complex_literal = 0; 
     58int close_or_connect = 0; 
     59int in_io_control_spec = 0; 
     60int intent_spec = 0; 
     61long int my_position; 
     62long int my_position_before; 
     63int suborfun = 0; 
     64int indeclaration = 0; 
     65int endoffile = 0; 
     66int in_inquire = 0; 
     67int in_char_selector = 0; 
     68int in_kind_selector =0; 
     69int char_length_toreset = 0; 
     70 
     71typedim my_dim; 
     72 
    5573listvar *test; 
     74 
     75char linebuf1[1024]; 
     76char linebuf2[1024]; 
    5677 
    5778int fortran_error(const char *s) 
    5879{ 
    59     printf("%s line %d, file %s motclef = |%s|\n", s, line_num_input, cur_filename, fortran_text); 
     80  if (endoffile == 1)  
     81  { 
     82  endoffile = 0; 
     83  return 0; 
     84  } 
     85    printf("%s line %d, file %s culprit = |%s|\n", s, line_num_input, cur_filename, strcat(linebuf1, linebuf2)); 
    6086    exit(1); 
    6187} 
    … …  
    94120%token TOK_PROGRAM 
    95121%token TOK_FUNCTION 
    96 %token TOK_FORMAT 
     122%token TOK_LABEL_FORMAT 
     123%token TOK_LABEL_CONTINUE 
     124%token TOK_LABEL_END_DO 
    97125%token TOK_MAX 
    98126%token TOK_TANH 
     127%token TOK_COMMENT 
    99128%token TOK_WHERE 
    100129%token TOK_ELSEWHEREPAR 
    … …  
    109138%token TOK_SELECTCASE 
    110139%token TOK_FILE 
     140%token TOK_REC 
     141%token TOK_NAME_EQ 
     142%token TOK_IOLENGTH 
     143%token TOK_ACCESS 
     144%token TOK_ACTION 
     145%token TOK_FORM 
     146%token TOK_RECL 
     147%token TOK_STATUS 
    111148%token TOK_UNIT 
     149%token TOK_OPENED 
    112150%token TOK_FMT 
    113151%token TOK_NML 
    114152%token TOK_END 
    115153%token TOK_EOR 
     154%token TOK_EOF 
    116155%token TOK_ERR 
     156%token TOK_POSITION 
     157%token TOK_IOSTAT 
     158%token TOK_IOMSG 
    117159%token TOK_EXIST 
    118160%token TOK_MIN 
    119161%token TOK_FLOAT 
    120162%token TOK_EXP 
     163%token TOK_LEN 
    121164%token TOK_COS 
    122165%token TOK_COSH 
    … …  
    139182%token TOK_MAXLOC 
    140183%token TOK_EXIT 
     184%token TOK_KIND 
     185%token TOK_MOLD 
     186%token TOK_SOURCE 
     187%token TOK_ERRMSG 
    141188%token TOK_MINVAL 
    142189%token TOK_PUBLIC 
    … …  
    150197%token TOK_PRINT 
    151198%token TOK_PLAINGOTO 
    152 %token TOK_LOGICALIF 
     199%token <na> TOK_LOGICALIF 
     200%token <na> TOK_LOGICALIF_PAR 
    153201%token TOK_PLAINDO 
    154202%token TOK_CONTAINS 
    … …  
    162210%token TOK_CLOSE 
    163211%token TOK_INQUIRE 
     212%token TOK_WRITE_PAR 
    164213%token TOK_WRITE 
    165 %token TOK_FLUSH 
     214%token <na> TOK_FLUSH 
     215%token TOK_READ_PAR 
    166216%token TOK_READ 
    167217%token TOK_REWIND 
    … …  
    192242%token TOK_PROCEDURE 
    193243%token TOK_STOP 
    194 %token TOK_REAL8 
    195244%token TOK_FOURDOTS 
    196245%token <na> TOK_HEXA 
    … …  
    214263%token <na> TOK_NOT 
    215264%token <na> TOK_AND 
     265%token <na> TOK_EQUALEQUAL 
     266%token <na> TOK_SLASHEQUAL 
     267%token <na> TOK_INFEQUAL 
     268%token <na> TOK_SUPEQUAL 
    216269%token <na> TOK_TRUE 
    217270%token <na> TOK_FALSE 
    218271%token <na> TOK_LABEL 
     272%token <na> TOK_LABEL_DJVIEW 
     273%token <na> TOK_PLAINDO_LABEL_DJVIEW 
     274%token <na> TOK_PLAINDO_LABEL 
    219275%token <na> TOK_TYPE 
    220276%token <na> TOK_TYPEPAR 
    221277%token <na> TOK_ENDTYPE 
     278%token TOK_COMMACOMPLEX 
    222279%token <na> TOK_REAL 
    223280%token <na> TOK_INTEGER 
    … …  
    246303%token '>' 
    247304%type <l> dcl 
    248 %type <l> after_type 
    249305%type <l> dimension 
     306%type <l> array-name-spec-list 
    250307%type <l> paramlist 
    251308%type <l> args 
     309%type <na> declaration-type-spec 
    252310%type <l> arglist 
    253311%type <lc> only_list 
     312%type <lc> only-list 
     313%type <lc> opt-only-list 
     314%type <lc> only 
    254315%type <lc> only_name 
    255 %type <lc> rename_list 
    256 %type <lc> rename_name 
     316%type <lc> rename-list 
     317%type <lc> opt-rename-list 
     318%type <lc> rename 
    257319%type <d> dims 
    258320%type <d> dimlist 
    … …  
    261323%type <na> comblock 
    262324%type <na> name_routine 
     325%type <na> type-param-value 
    263326%type <na> opt_name 
     327%type <na> constant-expr 
     328%type <na> ac-implied-do 
     329%type <na> subroutine-name 
     330%type <l> opt-dummy-arg-list-par 
     331%type <l> opt-dummy-arg-list 
     332%type <l> dummy-arg-list 
     333%type <l> named-constant-def-list 
     334%type <v> named-constant-def 
     335%type <na> ac-do-variable 
     336%type <na> data-i-do-variable 
     337%type <na> data-stmt-constant 
     338%type <na> do-variable 
     339%type <na> ac-implied-do-control 
     340%type <na> label 
     341%type <na> opt-label 
     342%type <na> label-djview 
     343%type <na> opt-label-djview 
    264344%type <na> type 
    265 %type <na> word_endsubroutine 
    266 %type <na> word_endfunction 
    267 %type <na> word_endprogram 
    268 %type <na> word_endunit 
     345%type <na> real-literal-constant 
     346%type <l> type-declaration-stmt 
     347%type <d> array-spec 
     348%type <d> assumed-shape-spec-list 
     349%type <d> deferred-shape-spec-list 
     350%type <d> assumed-size-spec 
     351%type <d> implied-shape-spec-list 
    269352%type <na> typespec 
     353%type <na> null-init 
     354%type <na> initial-data-target 
     355%type <na> intent-spec 
    270356%type <na> string_constant 
     357%type <na> access-id 
     358%type <na> dummy-arg-name 
     359%type <na> common-block-name 
     360%type <na> function-name 
     361%type <na> dummy-arg 
     362%type <na> lower-bound 
     363%type <na> upper-bound 
     364%type <na> scalar-constant-subobject 
     365%type <na> opt-data-stmt-star 
    271366%type <na> simple_const 
     367%type <na> opt-char-selector 
     368%type <na> char-selector 
    272369%type <na> ident 
    273370%type <na> intent_spec 
     371%type <na> kind-param 
    274372%type <na> signe 
     373%type <na> scalar-int-constant-expr 
    275374%type <na> opt_signe 
     375%type <dim1> explicit-shape-spec 
     376%type <d> explicit-shape-spec-list 
     377%type <dim1> assumed-shape-spec 
     378%type <dim1> deferred-shape-spec 
    276379%type <na> filename 
    277380%type <na> attribute 
    … …  
    279382%type <na> begin_array 
    280383%type <na> clause 
     384%type <na> only-use-name 
     385%type <na> generic-spec 
    281386%type <na> arg 
     387%type <d> opt-array-spec-par 
     388%type <d> opt-explicit-shape-spec-list-comma 
     389%type <d> explicit-shape-spec-list-comma 
    282390%type <na> uexpr 
     391%type <na> section_subscript_ambiguous 
    283392%type <na> minmaxlist 
     393%type <na> subscript 
     394%type <na> subscript-triplet 
     395%type <na> vector-subscript 
    284396%type <na> lhs 
    285 %type <na> vec 
    286397%type <na> outlist 
    287398%type <na> other 
     399%type <na> int-constant-expr 
    288400%type <na> dospec 
    289401%type <na> expr_data 
    … …  
    298410%type <na> opt_expr 
    299411%type <na> optexpr 
     412%type <v> entity-decl 
     413%type <l> entity-decl-list 
    300414%type <lnn> data_stmt_value_list 
     415%type <lnn> data-stmt-value-list 
     416%type <lnn> access-id-list 
     417%type <lnn> opt-access-id-list 
     418%type <na> data-stmt-value 
     419%type <l> data-stmt-object-list 
     420%type <l> data-i-do-object-list 
     421%type <v> data-stmt-object 
     422%type <v> data-i-do-object 
    301423%type <lnn> datanamelist 
    302424%type <na> after_slash 
    303425%type <na> after_equal 
    304426%type <na> predefinedfunction 
     427%type <na> equiv-op 
     428%type <na> or-op 
     429%type <na> and-op 
     430%type <na> not-op 
     431%type <na> equiv-operand 
     432%type <na> or-operand 
     433%type <na> and-operand 
     434%type <na> mult-operand 
     435%type <na> rel-op 
     436%type <na> concat-op 
     437%type <na> add-operand 
     438%type <na> add-op 
     439%type <na> power-op 
     440%type <na> section-subscript-list 
     441%type <na> opt-lower-bound-2points 
     442%type <na> mult-op 
     443%type <na> array-constructor 
    305444%type <na> expr 
     445%type <na> function-reference 
     446%type <na> literal-constant 
     447%type <na> named-constant 
     448%type <na> ac-value-list 
     449%type <na> ac-value 
     450%type <na> intrinsic-type-spec 
     451%type <na> opt-kind-selector 
     452%type <na> char-literal-constant 
     453%type <na> logical-literal-constant 
     454%type <na> real-part 
     455%type <na> imag-part 
     456%type <na> sign 
     457%type <na> signed-int-literal-constant 
     458%type <na> int-literal-constant 
     459%type <na> signed-real-literal-constant 
     460%type <na> complex-literal-constant 
     461%type <na> actual-arg-spec-list 
     462%type <na> procedure-designator 
     463%type <na> constant 
     464%type <na> data-ref 
     465%type <v> structure-component 
     466%type <v> scalar-structure-component 
     467%type <na> int-expr 
     468%type <na> ac-spec 
     469%type <na> type-spec 
     470%type <na> derived-type-spec 
     471%type <v> part-ref 
     472%type <na> opt-part-ref 
     473%type <na> actual-arg-spec 
     474%type <na> kind-selector 
     475%type <na> actual-arg 
     476%type <na> section-subscript 
     477%type <na> keyword 
     478%type <na> primary 
     479%type <na> specification-expr 
     480%type <v> variable 
     481%type <v> data-implied-do 
     482%type <na> substring-range 
     483%type <v> designator 
     484%type <na> object-name 
     485%type <na> object-name-noident 
     486%type <na> array-element 
     487%type <na> array-section 
     488%type <na> scalar-variable-name 
     489%type <na> scalar-constant 
     490%type <na> variable-name 
     491%type <na> opt-subscript  
     492%type <na> stride 
     493%type <na> opt-scalar-int-expr 
     494%type <na> scalar-int-expr 
     495%type <na> level-1-expr 
     496%type <na> level-2-expr 
     497%type <na> level-3-expr 
     498%type <na> level-4-expr 
     499%type <na> level-5-expr 
    306500%type <na> ubound 
    307501%type <na> operation 
    … …  
    311505 
    312506%% 
    313 input : 
     507/* R201 : program */ 
     508/*program: line-break 
     509     | program-unit 
     510     | program program-unit 
     511     ; 
     512*/ 
     513 
     514input: 
    314515      | input line 
    315516      ; 
    316 line :  line-break 
     517line:  line-break 
    317518      | suite_line_list 
    318       | TOK_LABEL suite_line_list 
    319519      | error {yyerrok;yyclearin;} 
    320520      ; 
    321 line-break: 
    322         '\n' fin_line 
     521line-break: '\n' fin_line 
     522      {token_since_endofstmt = 0; increment_nbtokens = 0;} 
    323523      | TOK_SEMICOLON 
     524      | TOK_EOF 
    324525      | line-break '\n' fin_line 
    325526      | line-break TOK_SEMICOLON 
    326       | line-break TOK_LABEL 
    327527      ; 
    328528suite_line_list : 
    … …  
    331531      | suite_line_list TOK_SEMICOLON suite_line 
    332532      ; 
    333 suite_line : 
    334         entry fin_line     /* subroutine, function, module                    */ 
    335       | spec fin_line      /* declaration                                     */ 
     533suite_line:program-unit 
    336534      | TOK_INCLUDE filename fin_line 
    337535        { 
    … …  
    342540            } 
    343541        } 
     542      | TOK_COMMENT 
     543      ; 
     544/* 
     545suite_line: 
     546        entry fin_line     subroutine, function, module                     
     547      | spec fin_line       declaration                                      
     548      | TOK_INCLUDE filename fin_line 
     549        { 
     550            if (inmoduledeclare == 0 ) 
     551            { 
     552                pos_end = setposcur(); 
     553                RemoveWordSET_0(fortran_out,pos_curinclude,pos_end-pos_curinclude); 
     554            } 
     555        } 
    344556      | execution-part-construct 
    345557      ; 
    346  
    347 fin_line : { pos_cur = setposcur(); } 
    348       ; 
    349  
     558*/ 
     559 
     560fin_line: { pos_cur = setposcur(); } 
     561      ; 
     562 
     563/* R202 : program-unit */ 
     564program-unit: main-program 
     565     | external-subprogram 
     566     | module 
     567     ; 
     568  
     569/*R203 : external-subprogram */ 
     570external-subprogram: function-subprogram 
     571     | subroutine-subprogram 
     572     ; 
     573      
    350574opt_recursive :         { isrecursive = 0; } 
    351575      | TOK_RECURSIVE   { isrecursive = 1; } 
    … …  
    356580      ; 
    357581 
    358 entry : opt_recursive TOK_SUBROUTINE name_routine arglist 
    359         { 
    360             insubroutinedeclare = 1; 
    361             if ( firstpass ) 
    362                 Add_SubroutineArgument_Var_1($4); 
    363             else 
    364                 WriteBeginof_SubLoop(); 
    365         } 
    366       | TOK_PROGRAM name_routine 
    367         { 
    368             insubroutinedeclare = 1; 
    369             inprogramdeclare = 1; 
    370             /* in the second step we should write the head of       */ 
    371             /*    the subroutine sub_loop_<subroutinename>          */ 
    372             if ( ! firstpass ) 
    373                 WriteBeginof_SubLoop(); 
    374         } 
    375       | opt_recursive TOK_FUNCTION name_routine arglist opt_result 
    376         { 
    377             insubroutinedeclare = 1; 
    378             strcpy(DeclType, ""); 
    379             /* we should to list of the subroutine argument the  */ 
    380             /*    name of the function which has to be defined   */ 
    381             if ( firstpass ) 
    382             { 
    383                 Add_SubroutineArgument_Var_1($4); 
    384                 if ( ! is_result_present ) 
    385                     Add_FunctionType_Var_1($3); 
    386             } 
    387             else 
    388             /* in the second step we should write the head of    */ 
    389             /*    the subroutine sub_loop_<subroutinename>       */ 
    390                 WriteBeginof_SubLoop(); 
    391         } 
    392       | TOK_MODULE TOK_NAME 
    393         { 
    394             GlobalDeclaration = 0; 
    395             strcpy(curmodulename,$2); 
    396             strcpy(subroutinename,""); 
    397             Add_NameOfModule_1($2); 
    398             if ( inmoduledeclare == 0 ) 
    399             { 
    400                 /* To know if there are in the module declaration    */ 
    401                 inmoduledeclare = 1; 
    402                 /* to know if a module has been met                  */ 
    403                 inmodulemeet = 1; 
    404                 /* to know if we are after the keyword contains      */ 
    405                 aftercontainsdeclare = 0 ; 
    406             } 
    407         } 
    408       ; 
    409  
    410 /* R312 : label */ 
    411 label: TOK_CSTINT 
    412      | label TOK_CSTINT 
    413      ; 
    414  
    415582name_routine :  TOK_NAME    { strcpy($$, $1); strcpy(subroutinename, $1); } 
    416583      ; 
    … …  
    419586arglist :               { if ( firstpass ) $$=NULL; } 
    420587      | '(' ')'         { if ( firstpass ) $$=NULL; } 
    421       | '(' args ')'    { if ( firstpass ) $$=$2; } 
     588      | '(' {in_complex_literal=0;} args ')'    { if ( firstpass ) $$=$3; } 
    422589      ; 
    423590arglist_after_result: 
    424591      | '(' ')' 
    425       | '(' args ')'    { if ( firstpass ) Add_SubroutineArgument_Var_1($2); } 
     592      | '(' {in_complex_literal=0;} args ')'    { if ( firstpass ) Add_SubroutineArgument_Var_1($3); } 
    426593      ; 
    427594args :  arg 
    … …  
    452619      | '*'     { strcpy($$,"*"); } 
    453620      ; 
    454 spec :  type after_type 
    455       | TOK_TYPE opt_spec opt_sep opt_name  { inside_type_declare = 1; } 
    456       | TOK_ENDTYPE opt_name                { inside_type_declare = 0; } 
    457       | TOK_POINTER list_couple 
    458       | before_parameter '(' paramlist ')' 
    459         { 
    460             if ( ! inside_type_declare ) 
    461             { 
    462                 if ( firstpass ) 
    463                 { 
    464                     if ( insubroutinedeclare )  Add_Parameter_Var_1($3); 
    465                     else                        Add_GlobalParameter_Var_1($3); 
    466                 } 
    467                 else 
    468                 { 
    469                     pos_end = setposcur(); 
    470                     RemoveWordSET_0(fortran_out, pos_cur_decl, pos_end-pos_cur_decl); 
    471                 } 
    472             } 
    473             VariableIsParameter =  0 ; 
    474         } 
    475       | before_parameter paramlist 
    476         { 
    477             if ( ! inside_type_declare ) 
    478             { 
    479                 if ( firstpass ) 
    480                 { 
    481                     if ( insubroutinedeclare )  Add_Parameter_Var_1($2); 
    482                     else                        Add_GlobalParameter_Var_1($2); 
    483                 } 
    484                 else 
    485                 { 
    486                     pos_end = setposcur(); 
    487                     RemoveWordSET_0(fortran_out,pos_cur_decl,pos_end-pos_cur_decl); 
    488                 } 
    489             } 
    490             VariableIsParameter =  0 ; 
    491         } 
    492       | common 
    493       | save 
    494         { 
    495             pos_end = setposcur(); 
    496             RemoveWordSET_0(fortran_out,pos_cursave,pos_end-pos_cursave); 
    497         } 
    498       | implicit 
    499       | dimension 
    500         { 
    501             /* if the variable is a parameter we can suppose that is   */ 
    502             /*    value is the same on each grid. It is not useless to */ 
    503             /*    create a copy of it on each grid                     */ 
    504             if ( ! inside_type_declare ) 
    505             { 
    506                 if ( firstpass ) 
    507                 { 
    508                     Add_Globliste_1($1); 
    509                     /* if variableparamlists has been declared in a subroutine   */ 
    510                     if ( insubroutinedeclare )     Add_Dimension_Var_1($1); 
    511                 } 
    512                 else 
    513                 { 
    514                     pos_end = setposcur(); 
    515                     RemoveWordSET_0(fortran_out,pos_curdimension,pos_end-pos_curdimension); 
    516                 } 
    517             } 
    518             PublicDeclare = 0; 
    519             PrivateDeclare = 0; 
    520             ExternalDeclare = 0; 
    521             strcpy(NamePrecision,""); 
    522             c_star = 0; 
    523             InitialValueGiven = 0 ; 
    524             strcpy(IntentSpec,""); 
    525             VariableIsParameter =  0 ; 
    526             Allocatabledeclare = 0 ; 
    527             Targetdeclare = 0 ; 
    528             SaveDeclare = 0; 
    529             pointerdeclare = 0; 
    530             optionaldeclare = 0 ; 
    531             dimsgiven=0; 
    532             c_selectorgiven=0; 
    533             strcpy(nameinttypename,""); 
    534             strcpy(c_selectorname,""); 
    535         } 
    536       | public 
    537         { 
    538             if (firstpass == 0) 
    539             { 
    540                 if ($1) 
    541                 { 
    542                     removeglobfromlist(&($1)); 
    543                     pos_end = setposcur(); 
    544                     RemoveWordSET_0(fortran_out,pos_cur,pos_end-pos_cur); 
    545                     writelistpublic($1); 
    546                 } 
    547             } 
    548         } 
    549       | private 
    550       | use_stat 
    551       | module_proc_stmt 
    552       | namelist 
    553       | TOK_BACKSPACE '(' expr ')' 
    554       | TOK_EXTERNAL opt_sep use_name_list 
    555       | TOK_INTRINSIC opt_sep use_intrinsic_list 
    556       | TOK_EQUIVALENCE list_expr_equi 
    557       | data_stmt '\n' 
    558         { 
    559             /* we should remove the data declaration                */ 
    560             pos_end = setposcur(); 
    561             RemoveWordSET_0(fortran_out,pos_curdata,pos_end-pos_curdata); 
    562  
    563             if ( aftercontainsdeclare == 1  && firstpass == 0 ) 
    564             { 
    565                 ReWriteDataStatement_0(fortran_out); 
    566                 pos_end = setposcur(); 
    567             } 
    568         } 
    569       ; 
     621 
    570622opt_spec : 
    571623      | access_spec 
    … …  
    619671      | list_expr_equi1 ',' ident dims 
    620672      ; 
    621 list_expr : 
     673list_expr: 
    622674                      expr 
    623675      | list_expr ',' expr 
    624676      ; 
    625 opt_sep : 
     677opt_sep: 
    626678      | TOK_FOURDOTS 
    627679      ; 
    628 after_type : 
    629         dcl nodimsgiven 
    630         { 
    631             /* if the variable is a parameter we can suppose that is*/ 
    632             /*    value is the same on each grid. It is not useless */ 
    633             /*    to create a copy of it on each grid               */ 
    634             if ( ! inside_type_declare ) 
    635             { 
    636                 pos_end = setposcur(); 
    637                 RemoveWordSET_0(fortran_out,pos_cur_decl,pos_end-pos_cur_decl); 
    638                 ReWriteDeclarationAndAddTosubroutine_01($1); 
    639                 pos_cur_decl = setposcur(); 
    640                 if ( firstpass == 0 && GlobalDeclaration == 0 
    641                                     && insubroutinedeclare == 0 ) 
    642                 { 
    643                     fprintf(fortran_out,"\n#include \"Module_Declar_%s.h\"\n", curmodulename); 
    644                     sprintf(ligne, "Module_Declar_%s.h", curmodulename); 
    645                     module_declar = open_for_write(ligne); 
    646                     GlobalDeclaration = 1 ; 
    647                     pos_cur_decl = setposcur(); 
    648                 } 
    649                 $$ = $1; 
    650  
    651                 if ( firstpass ) 
    652                 { 
    653                     Add_Globliste_1($1); 
    654                     if ( insubroutinedeclare ) 
    655                     { 
    656                         if ( pointerdeclare ) Add_Pointer_Var_From_List_1($1); 
    657                         Add_Parameter_Var_1($1); 
    658                     } 
    659                     else 
    660                         Add_GlobalParameter_Var_1($1); 
    661  
    662                     /* If there's a SAVE declaration in module's subroutines we should    */ 
    663                     /*    remove it from the subroutines declaration and add it in the    */ 
    664                     /*    global declarations                                             */ 
    665                     if ( aftercontainsdeclare && SaveDeclare ) 
    666                     { 
    667                         if ( inmodulemeet ) Add_SubroutineDeclarationSave_Var_1($1); 
    668                         else                Add_Save_Var_dcl_1($1); 
    669                     } 
    670                 } 
    671             } 
    672             else 
    673             { 
    674                 $$ = (listvar *) NULL; 
    675             } 
    676             PublicDeclare = 0; 
    677             PrivateDeclare = 0; 
    678             ExternalDeclare = 0; 
    679             strcpy(NamePrecision,""); 
    680             c_star = 0; 
    681             InitialValueGiven = 0 ; 
    682             strcpy(IntentSpec,""); 
    683             VariableIsParameter =  0 ; 
    684             Allocatabledeclare = 0 ; 
    685             Targetdeclare = 0 ; 
    686             SaveDeclare = 0; 
    687             pointerdeclare = 0; 
    688             optionaldeclare = 0 ; 
    689             dimsgiven=0; 
    690             c_selectorgiven=0; 
    691             strcpy(nameinttypename,""); 
    692             strcpy(c_selectorname,""); 
    693             GlobalDeclarationType = 0; 
    694         } 
    695       | before_function name_routine arglist 
    696         { 
    697             insubroutinedeclare = 1; 
    698  
    699             if ( firstpass ) 
    700             { 
    701                 Add_SubroutineArgument_Var_1($3); 
    702                 Add_FunctionType_Var_1($2); 
    703             } 
    704             else 
    705                 WriteBeginof_SubLoop(); 
    706  
    707             strcpy(nameinttypename,""); 
    708         } 
    709       ; 
     680 
    710681before_function :   TOK_FUNCTION    { functiondeclarationisdone = 1; } 
    711682      ; 
    712 before_parameter :  TOK_PARAMETER   { VariableIsParameter = 1; pos_curparameter = setposcur()-9; } 
     683before_parameter :  TOK_PARAMETER   {VariableIsParameter = 1; pos_curparameter = setposcur()-9; } 
    713684      ; 
    714685 
    … …  
    750721      ; 
    751722 
    752 save :  before_save varsave 
     723save:  before_save varsave 
    753724      | before_save comblock varsave 
    754725      | save opt_comma comblock opt_comma varsave 
    755726      | save ',' varsave 
    756727      ; 
    757 before_save : 
     728before_save: 
    758729        TOK_SAVE        { pos_cursave = setposcur()-4; } 
    759730      ; 
    … …  
    896867            strcpy(curvar->v_subroutinename,subroutinename); 
    897868            strcpy(curvar->v_modulename,curmodulename); 
    898             strcpy(curvar->v_initialvalue,$3); 
     869            curvar->v_initialvalue=Insertname(curvar->v_initialvalue,$3,0); 
    899870            strcpy(curvar->v_commoninfile,cur_filename); 
    900871            Save_Length($3,14); 
    … …  
    919890            } 
    920891        } 
    921       | TOK_IMPLICIT TOK_REAL8 
    922       ; 
    923 dcl :   options TOK_NAME dims lengspec initial_value 
     892      ; 
     893dcl:   options TOK_NAME dims lengspec initial_value 
    924894        { 
    925895            if ( ! inside_type_declare ) 
    … …  
    970940nodimsgiven : { dimsgiven = 0; } 
    971941      ; 
    972 type :  typespec selector               { strcpy(DeclType,$1);  } 
     942type:  typespec selector               { strcpy(DeclType,$1);} 
    973943      | before_character c_selector     { strcpy(DeclType,"character");  } 
    974944      | typespec '*' TOK_CSTINT         { strcpy(DeclType,$1); strcpy(nameinttypename,$3);  } 
    … …  
    993963      | TOK_COMPLEX         { strcpy($$,"complex"); pos_cur_decl = setposcur()-7; } 
    994964      | TOK_DOUBLECOMPLEX   { strcpy($$,"double complex"); pos_cur_decl = setposcur()-14; } 
    995       | TOK_DOUBLEPRECISION { pos_cur_decl = setposcur()-16; strcpy($$,"real"); strcpy(nameinttypename,"8"); } 
     965      | TOK_DOUBLEPRECISION { pos_cur_decl = setposcur()-16; strcpy($$,"real"); strcpy(nameinttypename,"8"); printf("OK1\n");} 
    996966      ; 
    997967lengspec : 
    … …  
    10331003      | ',' TOK_NAME clause 
    10341004      ; 
    1035 options : 
     1005options: 
    10361006      | TOK_FOURDOTS 
    10371007      | ',' attr_spec_list TOK_FOURDOTS 
    10381008      ; 
    1039 attr_spec_list : attr_spec 
     1009attr_spec_list: attr_spec 
    10401010      | attr_spec_list ',' attr_spec 
    10411011      ; 
    … …  
    10471017      | TOK_EXTERNAL        { ExternalDeclare = 1; } 
    10481018      | TOK_INTENT '(' intent_spec ')' 
    1049                             { strcpy(IntentSpec,$3); } 
     1019                            { strcpy(IntentSpec,$3); intent_spec = 0;} 
    10501020      | TOK_INTRINSIC 
    10511021      | TOK_OPTIONAL        { optionaldeclare = 1 ; } 
    … …  
    10641034      ; 
    10651035dims :  { $$ = (listdim*) NULL; } 
    1066       | '(' dimlist ')' 
     1036      | '(' {in_complex_literal=0;} dimlist ')' 
    10671037        { 
    10681038            $$ = (listdim*) NULL; 
    10691039            if ( inside_type_declare ) break; 
    1070             if ( created_dimensionlist == 1 || agrif_parentcall == 1 )  $$=$2; 
     1040            if ( created_dimensionlist == 1 || agrif_parentcall == 1 )  $$=$3; 
    10711041        } 
    10721042      ; 
    … …  
    10951065      | expr                { strcpy($$,$1);  } 
    10961066      ; 
    1097 expr :  uexpr               { strcpy($$,$1); } 
     1067/* 
     1068expr:  uexpr               { strcpy($$,$1); } 
    10981069      | complex_const       { strcpy($$,$1); } 
    10991070      | predefinedfunction  { strcpy($$,$1); } 
    11001071      | '(' expr ')'        { sprintf($$,"(%s)",$2); } 
    11011072      ; 
    1102  
     1073*/ 
    11031074predefinedfunction : 
    11041075        TOK_SUM minmaxlist ')'          { sprintf($$,"SUM(%s)",$2);} 
    … …  
    11341105uexpr : lhs                     { strcpy($$,$1); } 
    11351106      | simple_const            { strcpy($$,$1); } 
    1136       | vec                     { strcpy($$,$1); } 
    11371107      | expr operation          { sprintf($$,"%s%s",$1,$2); } 
    11381108      | signe expr %prec '*'    { sprintf($$,"%s%s",$1,$2); } 
    … …  
    11951165        begin_array                                         { strcpy($$,$1); if ( incalldeclare == 0 ) inagrifcallargument = 0;   } 
    11961166      | begin_array substring                               { sprintf($$," %s %s ",$1,$2); } 
    1197       | structure_component '(' funarglist ')'              { sprintf($$," %s ( %s )",$1,$3); } 
    1198       | structure_component '(' funarglist ')' substring    { sprintf($$," %s ( %s ) %s ",$1,$3,$5); } 
    1199       ; 
    1200 begin_array : 
    1201         ident '(' funarglist ')' 
     1167      | structure_component '(' {in_complex_literal=0;} funarglist ')'              { sprintf($$," %s ( %s )",$1,$4); } 
     1168      | structure_component '(' {in_complex_literal=0;} funarglist ')' substring    { sprintf($$," %s ( %s ) %s ",$1,$4,$6); } 
     1169      ; 
     1170begin_array : TOK_LOGICALIF 
     1171      |  ident '(' {in_complex_literal=0;} funarglist ')' 
    12021172        { 
    12031173            if ( inside_type_declare ) break; 
    1204             sprintf($$," %s ( %s )",$1,$3); 
    1205             ModifyTheAgrifFunction_0($3); 
     1174            sprintf($$," %s ( %s )",$1,$4); 
     1175            ModifyTheAgrifFunction_0($4); 
    12061176            agrif_parentcall = 0; 
    12071177        } 
    … …  
    12141184        } 
    12151185      ; 
     1186/* 
    12161187vec : 
    12171188        TOK_LEFTAB outlist TOK_RIGHTAB   { sprintf($$,"(/%s/)",$2); } 
    12181189      ; 
     1190*/ 
    12191191funarglist : 
    12201192        beforefunctionuse           { strcpy($$," "); } 
    … …  
    12381210      | ':'                     {  sprintf($$,":");} 
    12391211      ; 
    1240 ident : TOK_NAME 
    1241         { 
     1212ident: TOK_NAME 
     1213        { 
     1214       //  if (indeclaration == 1) break; 
    12421215            if ( afterpercent == 0 ) 
    12431216            { 
    … …  
    13031276      | substring   { strcpy($$,$1);} 
    13041277      ; 
     1278/* 
    13051279substring : 
    13061280        '(' optexpr ':' optexpr ')' { sprintf($$,"(%s :%s)",$2,$4);} 
    13071281      ; 
     1282*/ 
    13081283optexpr :           { strcpy($$," ");} 
    13091284      | expr        { strcpy($$,$1);} 
    13101285      ; 
    1311 opt_expr : 
    1312         '\n'        { strcpy($$," ");} 
     1286opt_expr :          { strcpy($$," ");} 
    13131287      | expr        { strcpy($$,$1);} 
    13141288      ; 
    1315 initial_value :     { InitialValueGiven = 0; } 
     1289initial_value:     { InitialValueGiven = 0; } 
    13161290      | '=' expr 
    13171291        { 
    … …  
    13301304        '(' uexpr ',' uexpr ')' {sprintf($$,"(%s,%s)",$2,$4); } 
    13311305      ; 
    1332 use_stat : 
    1333         word_use TOK_NAME 
    1334         { 
    1335             /* if variables has been declared in a subroutine       */ 
    1336             sprintf(charusemodule, "%s", $2); 
    1337             if ( firstpass ) 
    1338             { 
    1339                 Add_NameOfModuleUsed_1($2); 
     1306 
     1307only_list : 
     1308        only_name   {  $$ = $1; } 
     1309      | only_list ',' only_name 
     1310        { 
     1311            /* insert the variable in the list $1                 */ 
     1312            $3->suiv = $1; 
     1313            $$ = $3; 
     1314        } 
     1315      ; 
     1316only_name : 
     1317        TOK_NAME TOK_POINT_TO TOK_NAME 
     1318        { 
     1319            coupletmp = (listcouple *)calloc(1,sizeof(listcouple)); 
     1320            strcpy(coupletmp->c_namevar,$1); 
     1321            strcpy(coupletmp->c_namepointedvar,$3); 
     1322            coupletmp->suiv = NULL; 
     1323            $$ = coupletmp; 
     1324            pointedvar = 1; 
     1325            Add_UsedInSubroutine_Var_1($1); 
     1326        } 
     1327      | TOK_NAME 
     1328        { 
     1329            coupletmp = (listcouple *)calloc(1,sizeof(listcouple)); 
     1330            strcpy(coupletmp->c_namevar,$1); 
     1331            strcpy(coupletmp->c_namepointedvar,""); 
     1332            coupletmp->suiv = NULL; 
     1333            $$ = coupletmp; 
     1334        } 
     1335      ; 
     1336 
     1337/* R204 : specification-part */ 
     1338/* opt-implicit-part removed but implicit-stmt and format-stmt added to declaration-construct */ 
     1339specification-part: opt-use-stmt-list opt-declaration-construct-list 
     1340     ; 
     1341 
     1342opt-use-stmt-list: 
     1343     |use-stmt-list 
     1344     ; 
     1345      
     1346opt-implicit-part: 
     1347     |implicit-part 
     1348     ; 
     1349 
     1350implicit-part: opt-implicit-part-stmt-list implicit-stmt 
     1351     ; 
     1352      
     1353opt-implicit-part-stmt-list: 
     1354     | implicit-part-stmt-list 
     1355     ; 
     1356      
     1357implicit-part-stmt-list: implicit-part-stmt 
     1358     | implicit-part-stmt-list implicit-part-stmt 
     1359     ; 
     1360      
     1361/* R206: implicit-part-stmt */ 
     1362implicit-part-stmt: implicit-stmt 
     1363     | parameter-stmt 
     1364     | format-stmt 
     1365     ; 
     1366 
     1367 
     1368opt-declaration-construct-list: 
     1369     |declaration-construct-list 
     1370     ; 
     1371      
     1372declaration-construct-list: 
     1373        declaration-construct 
     1374      | declaration-construct-list declaration-construct 
     1375      ; 
     1376      
     1377/* R207 : declaration-construct */ 
     1378/* stmt-function-stmt replaced by assignment-stmt due to reduce conflicts */ 
     1379/* because assignment-stmt has been added  */ 
     1380/* Every statement that begins with a variable should be added */ 
     1381/* This include : */ 
     1382/* pointer-assignment-stmt, do-construct */ 
     1383/* implicit-stmt and format-stmt added since implicit-part-stmt has been removed due to conflicts (see R204) */ 
     1384/* ANOTHER SOLUTION TO THE PROBLEM OF STMT-FUNCTION IS NEEDED !!!! */ 
     1385/* BECAUSE ALMOST ALL ACTION-STMT SHOULD BE INCLUDED HERE !!! */ 
     1386 
     1387declaration-construct: derived-type-def 
     1388     | parameter-stmt 
     1389     | format-stmt 
     1390     | implicit-stmt 
     1391     | other-specification-stmt 
     1392     | type-declaration-stmt 
     1393     | assignment-stmt 
     1394     | pointer-assignment-stmt 
     1395     | do-construct 
     1396     | if-construct 
     1397     | continue-stmt 
     1398     | return-stmt 
     1399     | print-stmt 
     1400     ; 
     1401 
     1402opt-execution-part: 
     1403     | execution-part 
     1404     ; 
     1405 
     1406/* R208 : execution-part */ 
     1407execution-part: executable-construct opt-execution-part-construct-list 
     1408     ; 
     1409 
     1410opt-execution-part-construct-list: 
     1411     |execution-part-construct-list 
     1412     ; 
     1413 
     1414execution-part-construct-list: 
     1415        execution-part-construct 
     1416      | execution-part-construct-list execution-part-construct 
     1417      ; 
     1418 
     1419/* R209 : execution-part-construct */ 
     1420execution-part-construct: executable-construct 
     1421      | format-stmt 
     1422      ; 
     1423 
     1424opt-internal-subprogram-part: 
     1425     | internal-subprogram-part 
     1426     ; 
     1427      
     1428/* R120 : internal-subprogram-part */ 
     1429internal-subprogram-part: TOK_CONTAINS line-break 
     1430      opt-internal-subprogram 
     1431     ; 
     1432 
     1433opt-internal-subprogram: 
     1434     | internal-subprogram-list 
     1435     ; 
     1436 
     1437internal-subprogram-list: internal-subprogram 
     1438     | internal-subprogram-list internal-subprogram 
     1439     ; 
     1440 
     1441/* R211 : internal-subprogram */ 
     1442internal-subprogram: function-subprogram 
     1443     | subroutine-subprogram 
     1444     ; 
     1445 
     1446/* R212 : other-specification-stmt */ 
     1447other-specification-stmt: access-stmt 
     1448     | common-stmt 
     1449     | data-stmt 
     1450     | dimension-stmt 
     1451     | equivalence-stmt 
     1452     | external-stmt 
     1453     | intrinsic-stmt 
     1454     | namelist-stmt 
     1455     | save-stmt 
     1456     ; 
     1457 
     1458/* R213 : executable-construct */ 
     1459executable-construct: 
     1460        action-stmt 
     1461      | do-construct 
     1462      | case-construct 
     1463      | if-construct 
     1464      | where-construct 
     1465      ; 
     1466 
     1467/* R214 : action-stmt */ 
     1468 
     1469/* normal action-stmt */ 
     1470 
     1471action-stmt: 
     1472      allocate-stmt 
     1473      | assignment-stmt 
     1474      | call-stmt 
     1475      | close-stmt 
     1476      | continue-stmt 
     1477      | cycle-stmt 
     1478      | deallocate-stmt 
     1479      | goto-stmt 
     1480      | exit-stmt 
     1481      | flush-stmt 
     1482      | TOK_CYCLE opt_expr 
     1483      | TOK_NULLIFY '(' pointer_name_list ')' 
     1484      | TOK_ENDMODULE opt_name 
     1485        { 
     1486            /* if we never meet the contains keyword               */ 
     1487            if ( firstpass == 0 ) 
     1488            { 
     1489                RemoveWordCUR_0(fortran_out, strlen($2)+11);    // Remove word "end module" 
     1490                if ( inmoduledeclare && ! aftercontainsdeclare ) 
     1491                { 
     1492                    Write_Closing_Module(1); 
     1493                } 
     1494                fprintf(fortran_out,"\n      end module %s\n", curmodulename); 
     1495                if ( module_declar && insubroutinedeclare == 0 ) 
     1496                { 
     1497                    fclose(module_declar); 
     1498                } 
     1499            } 
     1500            inmoduledeclare = 0 ; 
     1501            inmodulemeet = 0 ; 
     1502            aftercontainsdeclare = 1; 
     1503            strcpy(curmodulename, ""); 
     1504            GlobalDeclaration = 0 ; 
     1505        } 
     1506      | if-stmt 
     1507      | inquire-stmt 
     1508      | open-stmt 
     1509      | pointer-assignment-stmt 
     1510      | print-stmt 
     1511      | read-stmt 
     1512      | return-stmt 
     1513      | rewind-stmt 
     1514      | stop-stmt 
     1515      | where-stmt 
     1516      | write-stmt 
     1517      | arithmetic-if-stmt 
     1518      ; 
     1519 
     1520/* R215 : keyword */ 
     1521keyword: ident 
     1522     ; 
     1523 
     1524scalar-constant: constant 
     1525    ; 
     1526 
     1527/* R304 : constant */ 
     1528 
     1529constant: literal-constant 
     1530     | named-constant 
     1531     ; 
     1532      
     1533/* R305 : literal-constant */ 
     1534literal-constant: int-literal-constant 
     1535     | real-literal-constant 
     1536     | logical-literal-constant 
     1537     | complex-literal-constant 
     1538     {in_complex_literal=0;} 
     1539     | char-literal-constant 
     1540     ; 
     1541      
     1542/* R306 : named-constant */ 
     1543named-constant: ident 
     1544     ; 
     1545 
     1546scalar-int-constant:int-constant 
     1547     ; 
     1548 
     1549/* R307 : int-constant */ 
     1550int-constant: int-literal-constant 
     1551     | named-constant 
     1552     ; 
     1553      
     1554/* 
     1555constant: TOK_CSTINT 
     1556     | TOK_CSTREAL 
     1557     | ident 
     1558     ; 
     1559*/ 
     1560 
     1561opt-label: 
     1562     {strcpy($$,"");} 
     1563     | label 
     1564     ; 
     1565 
     1566/* R312 : label */ 
     1567label: TOK_LABEL 
     1568     | TOK_CSTINT 
     1569     ; 
     1570 
     1571opt-label-djview: 
     1572     {strcpy($$,"");} 
     1573     | label-djview 
     1574     {strcpy($$,$1);} 
     1575     ; 
     1576      
     1577label-djview: TOK_LABEL_DJVIEW 
     1578     ; 
     1579 
     1580/* R401 : type-param-value */ 
     1581type-param-value: scalar-int-expr 
     1582     | '*' 
     1583     | ':' 
     1584     ; 
     1585 
     1586/* R402: type-spec */ 
     1587type-spec: intrinsic-type-spec 
     1588     {strcpy($$,$1);} 
     1589     | derived-type-spec 
     1590     {strcpy($$,$1);} 
     1591     ; 
     1592 
     1593/* R403 : declaration-type-spec */ 
     1594declaration-type-spec: {pos_cur_decl=my_position_before;} intrinsic-type-spec 
     1595     {strcpy($$,$2);} 
     1596     | TOK_TYPEPAR intrinsic-type-spec ')' 
     1597     | TOK_TYPEPAR derived-type-spec ')' 
     1598     {strcpy(DeclType,"type"); GlobalDeclarationType = 1;  } 
     1599     ; 
     1600 
     1601/* R404 : intrinsic-type-spec */ 
     1602intrinsic-type-spec: TOK_INTEGER {in_kind_selector = 1;} opt-kind-selector 
     1603     {sprintf($$,"%s%s",$1,$[opt-kind-selector]);strcpy(DeclType,$1); in_kind_selector =0;} 
     1604     | TOK_REAL {in_kind_selector = 1;} opt-kind-selector 
     1605     {sprintf($$,"%s%s",$1,$[opt-kind-selector]);strcpy(DeclType,$1);in_kind_selector =0;} 
     1606     | TOK_DOUBLEPRECISION {in_kind_selector = 1;} opt-kind-selector 
     1607     {sprintf($$,"%s%s",$1,$[opt-kind-selector]);strcpy(DeclType,"real"); strcpy(NamePrecision,"8");in_kind_selector =0;} 
     1608     | TOK_COMPLEX {in_kind_selector = 1;} opt-kind-selector 
     1609     {sprintf($$,"%s%s",$1,$[opt-kind-selector]);strcpy(DeclType,$1);in_kind_selector =0;} 
     1610     | TOK_CHARACTER {in_char_selector = 1;} opt-char-selector