New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Changeset 2715 for trunk/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modupdate.F – NEMO

Ignore:
Timestamp:
2011-03-30T17:58:35+02:00 (13 years ago)
Author:
rblod
Message:

First attempt to put dynamic allocation on the trunk

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modupdate.F

    r2528 r2715  
    7272      External :: procname 
    7373      Optional ::  procname       
    74       REAL, DIMENSION(lbound(child%var%array1,1): 
    75      &                ubound(child%var%array1,1)), Target :: tab  ! Results 
     74      REAL, DIMENSION( 
     75     &         child%var%lb(1):child%var%ub(1) 
     76     &         ), Target :: tab    ! Result 
    7677C 
    7778C 
    … …  
    8687C       
    8788C     Values on the current grid used for the update 
    88       childtemp % var % array1 => tab 
     89C      childtemp % var % array1 => tab 
    8990       
    9091      childtemp % var % lb = child % var % lb 
    … …  
    139140                                                           
    140141      REAL, DIMENSION( 
    141      &      lbound(child%var%array2,1):ubound(child%var%array2,1), 
    142      &      lbound(child%var%array2,2):ubound(child%var%array2,2)), 
    143      &      Target :: tab  ! Results 
     142     &         child%var%lb(1):child%var%ub(1), 
     143     &         child%var%lb(2):child%var%ub(2) 
     144     &    ), Target :: tab    ! Result 
    144145C 
    145146C 
    … …  
    154155C       
    155156C     Values on the current grid used for the update 
    156       childtemp % var % array2 => tab  
     157C      childtemp % var % array2 => tab  
    157158       
    158159      childtemp % var % lb = child % var % lb 
    … …  
    203204                                                        
    204205      REAL, DIMENSION( 
    205      &      lbound(child%var%array3,1):ubound(child%var%array3,1), 
    206      &      lbound(child%var%array3,2):ubound(child%var%array3,2), 
    207      &      lbound(child%var%array3,3):ubound(child%var%array3,3)), 
    208      &      Target :: tab  ! Results     
     206     &         child%var%lb(1):child%var%ub(1), 
     207     &         child%var%lb(2):child%var%ub(2), 
     208     &         child%var%lb(3):child%var%ub(3) 
     209     &      ), Target :: tab  ! Results   
    209210C 
    210211C 
    … …  
    219220C       
    220221C     Values on the current grid used for the update 
    221       childtemp % var % array3 => tab      
     222C      childtemp % var % array3 => tab      
    222223       
    223224      childtemp % var % lb = child % var % lb 
    … …  
    268269      Optional ::  procname         
    269270      REAL, DIMENSION( 
    270      &      lbound(child%var%array4,1):ubound(child%var%array4,1), 
    271      &      lbound(child%var%array4,2):ubound(child%var%array4,2), 
    272      &      lbound(child%var%array4,3):ubound(child%var%array4,3), 
    273      &      lbound(child%var%array4,4):ubound(child%var%array4,4)), 
    274      &      Target :: tab  ! Results 
     271     &         child%var%lb(1):child%var%ub(1), 
     272     &         child%var%lb(2):child%var%ub(2), 
     273     &         child%var%lb(3):child%var%ub(3), 
     274     &         child%var%lb(4):child%var%ub(4) 
     275     &      ), Target :: tab  ! Results 
    275276C 
    276277C 
    … …  
    285286C       
    286287C     Values on the current grid used for the update 
    287       childtemp % var % array4 => tab      
     288C      childtemp % var % array4 => tab      
    288289       
    289290      childtemp % var % lb = child % var % lb 
    … …  
    336337               
    337338      REAL, DIMENSION( 
    338      &      lbound(child%var%array5,1):ubound(child%var%array5,1), 
    339      &      lbound(child%var%array5,2):ubound(child%var%array5,2), 
    340      &      lbound(child%var%array5,3):ubound(child%var%array5,3), 
    341      &      lbound(child%var%array5,4):ubound(child%var%array5,4), 
    342      &      lbound(child%var%array5,5):ubound(child%var%array5,5)), 
    343      &      Target :: tab  ! Results 
     339     &         child%var%lb(1):child%var%ub(1), 
     340     &         child%var%lb(2):child%var%ub(2), 
     341     &         child%var%lb(3):child%var%ub(3), 
     342     &         child%var%lb(4):child%var%ub(4), 
     343     &         child%var%lb(5):child%var%ub(5) 
     344     &      ),  Target :: tab  ! Results 
    344345C 
    345346C 
    … …  
    354355C       
    355356C     Values on the current grid used for the update 
    356       childtemp % var % array5 => tab       
     357C      childtemp % var % array5 => tab       
    357358       
    358359      childtemp % var % lb = child % var % lb 
    … …  
    401402                                              ! are done on the fine grid        
    402403      REAL, DIMENSION( 
    403      &      lbound(child%var%array6,1):ubound(child%var%array6,1), 
    404      &      lbound(child%var%array6,2):ubound(child%var%array6,2), 
    405      &      lbound(child%var%array6,3):ubound(child%var%array6,3), 
    406      &      lbound(child%var%array6,4):ubound(child%var%array6,4), 
    407      &      lbound(child%var%array6,5):ubound(child%var%array6,5), 
    408      &      lbound(child%var%array6,6):ubound(child%var%array6,6)), 
    409      &      Target :: tab  ! Results 
     404     &         child%var%lb(1):child%var%ub(1), 
     405     &         child%var%lb(2):child%var%ub(2), 
     406     &         child%var%lb(3):child%var%ub(3), 
     407     &         child%var%lb(4):child%var%ub(4), 
     408     &         child%var%lb(5):child%var%ub(5), 
     409     &         child%var%lb(6):child%var%ub(6) 
     410     &      ),  Target :: tab  ! Results 
    410411C 
    411412C 
    … …  
    420421C       
    421422C     Values on the current grid used for the update 
    422       childtemp % var % array6 => tab       
     423C      childtemp % var % array6 => tab       
    423424       
    424425      childtemp % var % lb = child % var % lb 
    … …  
    522523          case('N') ! No space DIMENSION       
    523524C 
    524             select case (nbdim)  
    525 C       
    526               case(1) 
    527                 nbtab_Child(n) = SIZE(child % var % array1,n) - 1 
    528               case(2) 
    529                 nbtab_Child(n) = SIZE(child % var % array2,n) - 1 
    530               case(3) 
    531                 nbtab_Child(n) = SIZE(child % var % array3,n) - 1 
    532               case(4) 
    533                 nbtab_Child(n) = SIZE(child % var % array4,n) - 1 
    534               case(5) 
    535                 nbtab_Child(n) = SIZE(child % var % array5,n) - 1   
    536               case(6) 
    537                 nbtab_Child(n) = SIZE(child % var % array6,n) - 1  
    538 C 
    539             end select 
     525             
     526            nbtab_Child(n) = child % var % ub(n) - child % var % lb(n) 
    540527C 
    541528C           No interpolation but only a copy of the values of the grid variable       
    … …  
    560547      endif 
    561548      enddo 
    562       
     549 
    563550       IF (present(procname)) THEN 
    564551 
    … …  
    716703          indtab(i,1,1) = indtab(i,1,1) - coeffraf 
    717704          indtab(i,1,2) = indtab(i,1,2) - 1 
    718           IF ((TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) 
    719      &                            .AND.(mod(coeffraf,2) == 1)) THEN 
    720             indtab(i,1,1) = indtab(i,1,1) - 1 
    721             indtab(i,1,2) = indtab(i,1,2) + 1 
     705C at this point, indices are OK for an average           
     706          IF ((TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting)) THEN 
     707            indtab(i,1,1) = indtab(i,1,1) - coeffraf/2 
     708            indtab(i,1,2) = indtab(i,1,2) + coeffraf/2 
    722709          ENDIF 
    723710        ENDIF 
    … …  
    757744       
    758745      CALL MPI_ALLREDUCE(iminmaxg,lubglob,2*nbdim,MPI_INTEGER,MPI_MIN, 
    759      &                     MPI_COMM_AGRIF,code) 
     746     &                     MPI_COMM_WORLD,code) 
    760747 
    761748      lubglob(1:nbdim,2) = - lubglob(1:nbdim,2)       
    … …  
    763750#endif  
    764751C 
    765  
    766752      indtruetab(1:nbdim,1,1) = max(indtab(1:nbdim,1,1), 
    767753     &     lubglob(1:nbdim,1)) 
    … …  
    771757C 
    772758C 
    773  
    774759           IF (present(procname)) THEN 
    775760              Call Agrif_UpdatenD               
    … …  
    790775     &              posvartab_child,loctab_Child, 
    791776     &              nbdim)            
    792            ENDIF 
     777           ENDIF         
    793778C 
    794779C       
    … …  
    899884          indtab(i,2,2) = indtab(i,2,2) + coeffraf - 1 
    900885          IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN 
    901             indtab(i,1,1) = indtab(i,1,1) - 1 
    902             indtab(i,1,2) = indtab(i,1,2) + 1 
    903             indtab(i,2,1) = indtab(i,2,1) - 1 
    904             indtab(i,2,2) = indtab(i,2,2) + 1 
     886            indtab(i,1,1) = indtab(i,1,1) - coeffraf/2 
     887            indtab(i,1,2) = indtab(i,1,2) + coeffraf/2 
     888            indtab(i,2,1) = indtab(i,2,1) - coeffraf/2 
     889            indtab(i,2,2) = indtab(i,2,2) + coeffraf/2 
    905890          ENDIF           
    906891        ENDIF 
    … …  
    925910       
    926911      CALL MPI_ALLREDUCE(iminmaxg,lubglob,2*nbdim,MPI_INTEGER,MPI_MIN, 
    927      &                     MPI_COMM_AGRIF,code)   
     912     &                     MPI_COMM_WORLD,code)   
    928913      
    929914      lubglob(1:nbdim,2) = - lubglob(1:nbdim,2)       
    … …  
    12091194 
    12101195      Call Agrif_nbdim_Full_VarEQreal(tempC%var,0.,nbdim) 
    1211  
    1212  
    12131196 
    12141197      IF (present(procname)) THEN 
    … …  
    12871270C 
    12881271      Call MPI_ALLGATHER(tab3,4*nbdim,MPI_INTEGER,tab4,4*nbdim, 
    1289      &                   MPI_INTEGER,MPI_COMM_AGRIF,code) 
     1272     &                   MPI_INTEGER,MPI_COMM_WORLD,code) 
    12901273 
    12911274      IF (.not.associated(tempCextend%var)) Allocate(tempCextend%var) 
    … …  
    13001283      memberin1(1) = memberin 
    13011284      CALL MPI_ALLGATHER(memberin1,1,MPI_LOGICAL,memberinall, 
    1302      &                  1,MPI_LOGICAL,MPI_COMM_AGRIF,code) 
     1285     &                  1,MPI_LOGICAL,MPI_COMM_WORLD,code) 
    13031286  
    13041287       Call Get_External_Data_first(tab4t(:,:,1), 
    … …  
    14191402C 
    14201403      Call MPI_ALLGATHER(tab3,4*nbdim,MPI_INTEGER,tab4,4*nbdim, 
    1421      &                   MPI_INTEGER,MPI_COMM_AGRIF,code) 
     1404     &                   MPI_INTEGER,MPI_COMM_WORLD,code) 
    14221405 
    14231406      IF (.not.associated(tempPextend%var)) Allocate(tempPextend%var) 
    … …  
    14321415      memberin1(1) = member 
    14331416      CALL MPI_ALLGATHER(memberin1,1,MPI_LOGICAL,memberinall2, 
    1434      &                  1,MPI_LOGICAL,MPI_COMM_AGRIF,code) 
     1417     &                  1,MPI_LOGICAL,MPI_COMM_WORLD,code) 
    14351418  
    14361419      Call Get_External_Data_first(tab5t(:,:,1), 
    … …  
    17421725      REAL :: positionmin,positionmax 
    17431726      INTEGER :: imin,imax 
     1727      INTEGER :: coeffraf 
    17441728#endif 
    17451729C 
    … …  
    17701754          ENDIF 
    17711755        ELSE 
     1756          IF (TypeUpdate(i).NE.Agrif_Update_Full_Weighting) THEN 
    17721757        positionmin = positionmin - ds_Parent(i)/2. 
    1773         IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN 
    1774           positionmin = positionmin - ds_Child(i) 
     1758          ELSE 
     1759          coeffraf = nint(ds_Parent(i)/ds_Child(i)) 
     1760          if (mod(coeffraf,2) == 1) then 
     1761            positionmin = positionmin - (ds_Parent(i)-ds_Child(i)) 
     1762          else 
     1763            positionmin = positionmin - (ds_Parent(i)-ds_Child(i)) 
     1764     &                                -ds_Child(i)/2. 
     1765          endif 
    17751766        ENDIF 
    17761767        ENDIF 
    … …  
    17801771 
    17811772       positionmin = s_Child(i) + (imin - 
    1782      &                                pttab_Child(i)) * ds_Child(i) 
     1773     &                             pttab_Child(i)) * ds_Child(i) 
    17831774 
    17841775        pttruetabwhole(i) = imin 
    … …  
    17941785          ENDIF 
    17951786        ELSE 
     1787          IF (TypeUpdate(i).NE.Agrif_Update_Full_Weighting) THEN         
    17961788        positionmax = positionmax  + ds_Parent(i)/2. 
    1797         IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN 
    1798           positionmax = positionmax + ds_Child(i) 
     1789          ELSE 
     1790          coeffraf = nint(ds_Parent(i)/ds_Child(i)) 
     1791          if (mod(coeffraf,2) == 1) then 
     1792            positionmax = positionmax + (ds_Parent(i)-ds_Child(i)) 
     1793          else 
     1794            positionmax = positionmax + (ds_Parent(i)-ds_Child(i))  
     1795     &                                + ds_Child(i)/2. 
     1796          endif 
     1797 
    17991798        ENDIF         
    18001799        ENDIF 
Note: See TracChangeset for help on using the changeset viewer.