- Timestamp:
- 2019-02-27T14:55:54+01:00 (6 years ago)
- Location:
- vendors/AGRIF/CMEMS_2020
- Files:
-
- 23 edited
Legend:
- Unmodified
- Added
- Removed
-
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modarrays.F90
r10087 r10725 88 88 ub_glob_index = ub_var(i) 89 89 #endif 90 91 90 lb_tab_true(i) = max(lb_tab(i), lb_glob_index) 92 91 ub_tab_true(i) = min(ub_tab(i), ub_glob_index) … … 234 233 case (1) ; call Agrif_set_array_tozero_1D(variable%array1) 235 234 case (2) ; call Agrif_set_array_tozero_2D(variable%array2) 236 case (3) ; call Agrif_set_array_tozero_reshape(variable%array3,size(variable%array3)) 237 !case (3) ; call Agrif_set_array_tozero_3D(variable%array3) 235 case (3) ; call Agrif_set_array_tozero_3D(variable%array3) 238 236 case (4) ; call Agrif_set_array_tozero_4D(variable%array4) 239 237 case (5) ; call Agrif_set_array_tozero_5D(variable%array5) … … 276 274 !=================================================================================================== 277 275 ! 278 !===================================================================================================279 !280 !===================================================================================================281 ! subroutine agrif_set_array_cond282 !283 !> Compute the masking of \b variablein, according to the required dimension.284 !---------------------------------------------------------------------------------------------------285 subroutine agrif_set_array_cond ( variablein, variableout, value, nbdim )286 !---------------------------------------------------------------------------------------------------287 type(Agrif_Variable), intent(in) :: variablein !< Variablein288 type(Agrif_Variable), intent(inout) :: variableout !< Variableout289 real,intent(in) :: value !< special value290 integer, intent(in) :: nbdim !< Dimension of the array291 292 !293 select case (nbdim)294 case (1) ; call agrif_set_array_cond_1D(variablein%array1,variableout%array1,value)295 case (2) ; call agrif_set_array_cond_2D(variablein%array2,variableout%array2,value)296 case (3) ; call agrif_set_array_cond_reshape(variablein%array3,variableout%array3,value,size(variablein%array3))297 ! case (3) ; call agrif_set_array_cond_3D(variablein%array3,variableout%array3,value)298 case (4) ; call agrif_set_array_cond_4D(variablein%array4,variableout%array4,value)299 case (5) ; call agrif_set_array_cond_5D(variablein%array5,variableout%array5,value)300 case (6) ; call agrif_set_array_cond_6D(variablein%array6,variableout%array6,value)301 end select302 !---------------------------------------------------------------------------------------------------303 contains304 !---------------------------------------------------------------------------------------------------305 subroutine agrif_set_array_cond_1D(arrayin,arrayout,value)306 real,dimension(:),intent(in) :: arrayin307 real,dimension(:),intent(out) :: arrayout308 real :: value309 310 where (arrayin == value)311 arrayout = 0.312 elsewhere313 arrayout = 1.314 end where315 316 end subroutine agrif_set_array_cond_1D317 !318 subroutine agrif_set_array_cond_2D(arrayin,arrayout,value)319 real,dimension(:,:),intent(in) :: arrayin320 real,dimension(:,:),intent(out) :: arrayout321 real :: value322 323 where (arrayin == value)324 arrayout = 0.325 elsewhere326 arrayout = 1.327 end where328 329 end subroutine agrif_set_array_cond_2D330 !331 subroutine agrif_set_array_cond_3D(arrayin,arrayout,value)332 real,dimension(:,:,:),intent(in) :: arrayin333 real,dimension(:,:,:),intent(out) :: arrayout334 real :: value335 336 where (arrayin == value)337 arrayout = 0.338 elsewhere339 arrayout = 1.340 end where341 342 end subroutine agrif_set_array_cond_3D343 !344 subroutine agrif_set_array_cond_4D(arrayin,arrayout,value)345 real,dimension(:,:,:,:),intent(in) :: arrayin346 real,dimension(:,:,:,:),intent(out) :: arrayout347 real :: value348 349 where (arrayin == value)350 arrayout = 0.351 elsewhere352 arrayout = 1.353 end where354 355 end subroutine agrif_set_array_cond_4D356 !357 subroutine agrif_set_array_cond_5D(arrayin,arrayout,value)358 real,dimension(:,:,:,:,:),intent(in) :: arrayin359 real,dimension(:,:,:,:,:),intent(out) :: arrayout360 real :: value361 362 where (arrayin == value)363 arrayout = 0.364 elsewhere365 arrayout = 1.366 end where367 368 end subroutine agrif_set_array_cond_5D369 !370 subroutine agrif_set_array_cond_6D(arrayin,arrayout,value)371 real,dimension(:,:,:,:,:,:),intent(in) :: arrayin372 real,dimension(:,:,:,:,:,:),intent(out) :: arrayout373 real :: value374 375 where (arrayin == value)376 arrayout = 0.377 elsewhere378 arrayout = 1.379 end where380 381 end subroutine agrif_set_array_cond_6D382 !---------------------------------------------------------------------------------------------------383 end subroutine agrif_set_array_cond384 276 !=================================================================================================== 385 277 ! subroutine Agrif_var_copy_array … … 446 338 real, dimension(l(1):,l(2):,l(3):), intent(out) :: tabout 447 339 real, dimension(m(1):,m(2):,m(3):), intent(in) :: tabin 448 integer :: i,j,k 449 450 451 !$OMP PARALLEL DO DEFAULT(none) PRIVATE(i,j,k) & 452 !$OMP SHARED(inf1,inf2,sup1,sup2,tabin,tabout) & 453 !$OMP SCHEDULE(RUNTIME) 454 do k=inf1(3),sup1(3) 455 do j=inf1(2),sup1(2) 456 do i=inf1(1),sup1(1) 457 ! tabout(i,j,k) = tabin(i+inf2(1)-inf1(1),j+inf2(2)-inf1(2),k+inf2(3)-inf1(3)) 458 tabout(i,j,k) = tabin(i,j,k) 459 enddo 460 enddo 461 enddo 462 !$OMP END PARALLEL DO 463 464 465 ! tabout(inf1(1):sup1(1), & 466 ! inf1(2):sup1(2), & 467 ! inf1(3):sup1(3)) = tabin(inf2(1):sup2(1), & 468 ! inf2(2):sup2(2), & 469 ! inf2(3):sup2(3)) 340 tabout(inf1(1):sup1(1), & 341 inf1(2):sup1(2), & 342 inf1(3):sup1(3)) = tabin(inf2(1):sup2(1), & 343 inf2(2):sup2(2), & 344 inf2(3):sup2(3)) 470 345 end subroutine Agrif_copy_array_3d 471 346 ! … … 764 639 integer, dimension(6), intent(out) :: lb_child !< Lower bound on the child grid 765 640 integer, dimension(6), intent(out) :: lb_parent !< Lower bound on the parent grid 766 real (kind=8), dimension(6), intent(out):: s_child !< Child grid position (s_root = 0)767 real (kind=8), dimension(6), intent(out):: s_parent !< Parent grid position (s_root = 0)768 real (kind=8), dimension(6), intent(out):: ds_child !< Child grid dx (ds_root = 1)769 real (kind=8), dimension(6), intent(out):: ds_parent !< Parent grid dx (ds_root = 1)641 real, dimension(6), intent(out) :: s_child !< Child grid position (s_root = 0) 642 real, dimension(6), intent(out) :: s_parent !< Parent grid position (s_root = 0) 643 real, dimension(6), intent(out) :: ds_child !< Child grid dx (ds_root = 1) 644 real, dimension(6), intent(out) :: ds_parent !< Parent grid dx (ds_root = 1) 770 645 integer, intent(out) :: nbdim !< Number of dimensions 771 646 logical, intent(in) :: interp !< .true. if preprocess for interpolation, \n … … 804 679 else 805 680 ub_child(n) = lb_child(n) + Agrif_Child_Gr % nb(1) - 1 806 s_child(n) = s_child(n) + 0.5 d0*ds_child(n)807 s_parent(n) = s_parent(n) + 0.5 d0*ds_parent(n)681 s_child(n) = s_child(n) + 0.5*ds_child(n) 682 s_parent(n) = s_parent(n) + 0.5*ds_parent(n) 808 683 endif 809 684 ! … … 822 697 else 823 698 ub_child(n) = lb_child(n) + Agrif_Child_Gr % nb(2) - 1 824 s_child(n) = s_child(n) + 0.5 d0*ds_child(n)825 s_parent(n) = s_parent(n) + 0.5 d0*ds_parent(n)699 s_child(n) = s_child(n) + 0.5*ds_child(n) 700 s_parent(n) = s_parent(n) + 0.5*ds_parent(n) 826 701 endif 827 702 ! … … 860 735 ! No interpolation but only a copy of the values of the grid variable 861 736 lb_parent(n) = lb_child(n) 862 s_child(n) = 0. d0863 s_parent(n) = 0. d0864 ds_child(n) = 1. d0865 ds_parent(n) = 1. d0737 s_child(n) = 0. 738 s_parent(n) = 0. 739 ds_child(n) = 1. 740 ds_parent(n) = 1. 866 741 ! 867 742 end select … … 966 841 ! 967 842 end module Agrif_Arrays 968 969 970 subroutine agrif_set_array_cond_reshape(arrayin,arrayout,value,n)971 integer :: n972 real,dimension(n) :: arrayin,arrayout973 real :: value974 975 integer :: i976 977 do i=1,n978 if (arrayin(i) == value) then979 arrayout(i) = 0.980 else981 arrayout(i) = 1.982 endif983 enddo984 985 end subroutine agrif_set_array_cond_reshape986 987 subroutine agrif_set_array_tozero_reshape(array,n)988 integer :: n989 real,dimension(n) :: array990 991 integer :: i992 993 !$OMP PARALLEL DO DEFAULT(none) PRIVATE(i) &994 !$OMP SHARED(array,n)995 do i=1,n996 array(i) = 0.997 enddo998 !$OMP END PARALLEL DO999 1000 end subroutine agrif_set_array_tozero_reshape -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modbc.F90
r10087 r10725 32 32 ! 33 33 implicit none 34 REAL,DIMENSION(:),ALLOCATABLE :: parray_temp35 34 ! 36 35 contains … … 62 61 integer, dimension(6) :: loctab_child ! Indicates if the child grid has a common border 63 62 ! with the root grid 64 real (kind=8), dimension(6) :: s_child, s_parent ! Positions of the parent and child grids65 real (kind=8), dimension(6) :: ds_child, ds_parent ! Space steps of the parent and child grids63 real, dimension(6) :: s_child, s_parent ! Positions of the parent and child grids 64 real, dimension(6) :: ds_child, ds_parent ! Space steps of the parent and child grids 66 65 ! 67 66 call PreProcessToInterpOrUpdate( parent, child, & … … 146 145 INTEGER, DIMENSION(nbdim) :: posvartab_Child !< Position of the grid variable (1 or 2) 147 146 INTEGER, DIMENSION(nbdim) :: loctab_Child !< Indicates if the child grid has a common border with the root grid 148 REAL (kind=8), DIMENSION(nbdim) :: s_Child, s_Parent !< Positions of the parent and child grids149 REAL (kind=8), DIMENSION(nbdim) :: ds_Child, ds_Parent !< Space steps of the parent and child grids147 REAL , DIMENSION(nbdim) :: s_Child, s_Parent !< Positions of the parent and child grids 148 REAL , DIMENSION(nbdim) :: ds_Child, ds_Parent !< Space steps of the parent and child grids 150 149 INTEGER :: nbdim !< Number of dimensions of the grid variable 151 150 procedure() :: procname !< Data recovery procedure … … 160 159 INTEGER,DIMENSION(nbdim,2,2,nbdim) :: ptres,ptres2 ! calculated 161 160 INTEGER,DIMENSION(nbdim) :: coords 162 INTEGER :: i, nb, ndir ,j,k,l161 INTEGER :: i, nb, ndir 163 162 INTEGER :: n, sizetab 164 163 INTEGER :: ibeg, iend 165 164 INTEGER :: i1,i2,j1,j2,k1,k2,l1,l2,m1,m2,n1,n2 166 165 REAL :: c1t,c2t ! Coefficients for the time interpolation (c2t=1-c1t) 167 INTEGER :: isize168 INTEGER :: kindex_2d(2,nbdim)169 170 166 #if defined AGRIF_MPI 171 167 ! … … 192 188 END WHERE 193 189 ! 194 ! call Agrif_get_var_global_bounds(child,lubglob,nbdim) 195 lubglob = child%lubglob(1:nbdim,:) 190 call Agrif_get_var_global_bounds(child,lubglob,nbdim) 196 191 ! 197 192 indtruetab(1:nbdim,1,1) = max(indtab(1:nbdim,1,1), lubglob(1:nbdim,1)) … … 199 194 indtruetab(1:nbdim,2,1) = min(indtab(1:nbdim,2,1), lubglob(1:nbdim,2)) 200 195 indtruetab(1:nbdim,2,2) = min(indtab(1:nbdim,2,2), lubglob(1:nbdim,2)) 201 202 196 ! 203 197 do nb = 1,nbdim … … 273 267 if (loctab_child(nb) /= (-ndir) .AND. loctab_child(nb) /= -3) then 274 268 ! 275 276 269 call Agrif_InterpnD(type_interp, parent, child, & 277 270 ptres(1:nbdim,1,ndir,nb), & … … 326 319 do nb = 1,nbdim 327 320 do ndir = 1,2 328 kindex_2d(ndir,nb) = kindex 329 if ( (loctab_child(nb) /= (-ndir)) .AND. (loctab_child(nb) /= -3) .AND. child%memberin(nb,ndir) ) then 321 if (loctab_child(nb) /= (-ndir) .AND. loctab_child(nb) /= -3) then 330 322 Call timeInterpolation(child,ptres2(:,:,ndir,nb),kindex,c1t,c2t,nbdim) 331 323 endif … … 333 325 enddo 334 326 ! 327 endif 328 ! 335 329 do nb = 1,nbdim 336 330 do ndir = 1,2 337 331 if ( (loctab_child(nb) /= (-ndir)) .AND. (loctab_child(nb) /= -3) .AND. child%memberin(nb,ndir) ) then 338 339 do i=1,nbdim340 if (ptres2(i,1,ndir,nb) /= child%childarray(i,1,2,nb,ndir)) then341 print *,'problem ptres2 childarray 1 ',ptres2(i,1,ndir,nb) /= child%childarray(i,1,2,nb,ndir)342 stop343 endif344 if (ptres2(i,2,ndir,nb) /= child%childarray(i,2,2,nb,ndir)) then345 print *,'problem ptres2 childarray 2 ',ptres2(i,2,ndir,nb) /= child%childarray(i,2,2,nb,ndir)346 stop347 endif348 enddo349 350 332 select case(nbdim) 351 333 case(1) … … 364 346 i1,i2,j1,j2, .FALSE.,coords(nb),ndir) 365 347 case(3) 366 367 348 i1 = child % childarray(1,1,2,nb,ndir) 368 349 i2 = child % childarray(1,2,2,nb,ndir) … … 372 353 k2 = child % childarray(3,2,2,nb,ndir) 373 354 374 call procname(parray_temp(kindex_2d(ndir,nb)),i1,i2,j1,j2,k1,k2, .FALSE.,coords(nb),ndir)375 355 call procname(parray3(i1:i2,j1:j2,k1:k2), & 356 i1,i2,j1,j2,k1,k2, .FALSE.,coords(nb),ndir) 376 357 case(4) 377 358 i1 = child % childarray(1,1,2,nb,ndir) … … 384 365 l2 = child % childarray(4,2,2,nb,ndir) 385 366 386 call procname(parray _temp(kindex_2d(ndir,nb)),i1,i2,j1,j2,k1,k2,l1,l2,.FALSE.,coords(nb),ndir)387 367 call procname(parray4(i1:i2,j1:j2,k1:k2,l1:l2), & 368 i1,i2,j1,j2,k1,k2,l1,l2, .FALSE.,coords(nb),ndir) 388 369 case(5) 389 370 i1 = child % childarray(1,1,2,nb,ndir) … … 420 401 enddo 421 402 enddo 422 423 else424 425 do nb = 1,nbdim426 do ndir = 1,2427 if ( (loctab_child(nb) /= (-ndir)) .AND. (loctab_child(nb) /= -3) .AND. child%memberin(nb,ndir) ) then428 select case(nbdim)429 case(1)430 i1 = child % childarray(1,1,2,nb,ndir)431 i2 = child % childarray(1,2,2,nb,ndir)432 433 call procname(parray1(i1:i2), &434 i1,i2, .FALSE.,coords(nb),ndir)435 case(2)436 i1 = child % childarray(1,1,2,nb,ndir)437 i2 = child % childarray(1,2,2,nb,ndir)438 j1 = child % childarray(2,1,2,nb,ndir)439 j2 = child % childarray(2,2,2,nb,ndir)440 441 call procname(parray2(i1:i2,j1:j2), &442 i1,i2,j1,j2, .FALSE.,coords(nb),ndir)443 case(3)444 445 i1 = child % childarray(1,1,2,nb,ndir)446 i2 = child % childarray(1,2,2,nb,ndir)447 j1 = child % childarray(2,1,2,nb,ndir)448 j2 = child % childarray(2,2,2,nb,ndir)449 k1 = child % childarray(3,1,2,nb,ndir)450 k2 = child % childarray(3,2,2,nb,ndir)451 452 call procname(parray3(i1:i2,j1:j2,k1:k2), &453 i1,i2,j1,j2,k1,k2, .FALSE.,coords(nb),ndir)454 455 case(4)456 i1 = child % childarray(1,1,2,nb,ndir)457 i2 = child % childarray(1,2,2,nb,ndir)458 j1 = child % childarray(2,1,2,nb,ndir)459 j2 = child % childarray(2,2,2,nb,ndir)460 k1 = child % childarray(3,1,2,nb,ndir)461 k2 = child % childarray(3,2,2,nb,ndir)462 l1 = child % childarray(4,1,2,nb,ndir)463 l2 = child % childarray(4,2,2,nb,ndir)464 465 call procname(parray4(i1:i2,j1:j2,k1:k2,l1:l2), &466 i1,i2,j1,j2,k1,k2,l1,l2, .FALSE.,coords(nb),ndir)467 468 case(5)469 i1 = child % childarray(1,1,2,nb,ndir)470 i2 = child % childarray(1,2,2,nb,ndir)471 j1 = child % childarray(2,1,2,nb,ndir)472 j2 = child % childarray(2,2,2,nb,ndir)473 k1 = child % childarray(3,1,2,nb,ndir)474 k2 = child % childarray(3,2,2,nb,ndir)475 l1 = child % childarray(4,1,2,nb,ndir)476 l2 = child % childarray(4,2,2,nb,ndir)477 m1 = child % childarray(5,1,2,nb,ndir)478 m2 = child % childarray(5,2,2,nb,ndir)479 480 call procname(parray5(i1:i2,j1:j2,k1:k2,l1:l2,m1:m2), &481 i1,i2,j1,j2,k1,k2,l1,l2,m1,m2, .FALSE.,coords(nb),ndir)482 case(6)483 i1 = child % childarray(1,1,2,nb,ndir)484 i2 = child % childarray(1,2,2,nb,ndir)485 j1 = child % childarray(2,1,2,nb,ndir)486 j2 = child % childarray(2,2,2,nb,ndir)487 k1 = child % childarray(3,1,2,nb,ndir)488 k2 = child % childarray(3,2,2,nb,ndir)489 l1 = child % childarray(4,1,2,nb,ndir)490 l2 = child % childarray(4,2,2,nb,ndir)491 m1 = child % childarray(5,1,2,nb,ndir)492 m2 = child % childarray(5,2,2,nb,ndir)493 n1 = child % childarray(6,1,2,nb,ndir)494 n2 = child % childarray(6,2,2,nb,ndir)495 496 call procname(parray6(i1:i2,j1:j2,k1:k2,l1:l2,m1:m2,n1:n2), &497 i1,i2,j1,j2,k1,k2,l1,l2,m1,m2,n1,n2, .FALSE.,coords(nb),ndir)498 end select499 endif500 enddo501 enddo502 503 endif504 !505 506 403 !--------------------------------------------------------------------------------------------------- 507 404 end subroutine Agrif_Correctnd … … 628 525 ! 629 526 INTEGER :: ir,jr,kr,lr,mr,nr 630 INTEGER :: kindexmax, isize,i631 REAL,DIMENSION(:),ALLOCATABLE :: tabtemp632 633 isize = 1634 DO i=1,nbdim635 isize = isize * (bounds(i,2)-bounds(i,1)+1)636 ENDDO637 IF (isize <= 0) RETURN638 639 kindexmax = kindex + isize - 1640 IF (.NOT.ALLOCATED(parray_temp)) THEN641 ALLOCATE(parray_temp(kindexmax))642 ELSE643 IF (size(parray_temp) < kindexmax) THEN644 ALLOCATE(tabtemp(size(parray_temp)))645 tabtemp = parray_temp646 DEALLOCATE(parray_temp)647 ALLOCATE(parray_temp(kindexmax))648 parray_temp(1:size(tabtemp)) = tabtemp649 DEALLOCATE(tabtemp)650 ENDIF651 ENDIF652 653 527 ! 654 528 SELECT CASE (nbdim) … … 672 546 ! 673 547 CASE (3) 674 675 parray_temp(kindex:kindexmax) = c2t*child_var % oldvalues2d(1,kindex:kindexmax) + & 676 c1t*child_var % oldvalues2d(2,kindex:kindexmax) 677 548 do kr = bounds(3,1),bounds(3,2) 549 do jr = bounds(2,1),bounds(2,2) 550 !CDIR ALTCODE 551 do ir = bounds(1,1),bounds(1,2) 552 parray3(ir,jr,kr) = c2t*child_var % oldvalues2d(1,kindex) + & 553 c1t*child_var % oldvalues2d(2,kindex) 554 kindex = kindex + 1 555 enddo 556 enddo 557 enddo 678 558 ! 679 559 CASE (4) 680 681 parray_temp(kindex:kindexmax) = c2t*child_var % oldvalues2d(1,kindex:kindexmax) + & 682 c1t*child_var % oldvalues2d(2,kindex:kindexmax) 683 560 do lr = bounds(4,1),bounds(4,2) 561 do kr = bounds(3,1),bounds(3,2) 562 do jr = bounds(2,1),bounds(2,2) 563 !CDIR ALTCODE 564 do ir = bounds(1,1),bounds(1,2) 565 parray4(ir,jr,kr,lr) = c2t*child_var % oldvalues2d(1,kindex) + & 566 c1t*child_var % oldvalues2d(2,kindex) 567 kindex = kindex + 1 568 enddo 569 enddo 570 enddo 571 enddo 684 572 ! 685 573 CASE (5) … … 717 605 enddo 718 606 END SELECT 719 720 kindex = kindexmax + 1721 722 607 !--------------------------------------------------------------------------------------------------- 723 608 end subroutine timeInterpolation -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modbcfunction.F90
r10087 r10725 21 21 ! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 22 22 ! 23 !---------------------------------------------------------------------------------------------------24 23 !> Module Agrif_BcFunction. 25 !! 26 !--------------------------------------------------------------------------------------------------- 24 ! 27 25 module Agrif_BcFunction 28 26 ! 29 27 ! Modules used: 30 28 ! 31 use Agrif_User_Variables 32 29 use Agrif_Boundary 30 use Agrif_Update 31 use Agrif_Save 33 32 ! 34 33 implicit none 34 ! 35 interface Agrif_Set_Parent 36 module procedure Agrif_Set_Parent_int, & 37 Agrif_Set_Parent_real4, & 38 Agrif_Set_Parent_real8 39 end interface 35 40 ! 36 41 interface Agrif_Save_Forrestore … … 42 47 ! 43 48 contains 44 49 ! 50 !=================================================================================================== 51 ! subroutine Agrif_Set_parent_int 52 ! 53 !> To set the TYPE of the variable 54 !--------------------------------------------------------------------------------------------------- 55 subroutine Agrif_Set_parent_int(integer_variable,value) 56 !--------------------------------------------------------------------------------------------------- 57 integer, intent(in) :: integer_variable !< indice of the variable in tabvars 58 integer, intent(in) :: value !< input value 59 ! 60 61 integer :: i 62 logical :: i_found 63 64 i_found = .FALSE. 65 66 do 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 72 enddo 73 74 if (.NOT.i_found) STOP 'Agrif_Set_Integer : Variable not found' 75 76 !--------------------------------------------------------------------------------------------------- 77 end subroutine Agrif_Set_parent_int 78 !=================================================================================================== 79 ! 80 !=================================================================================================== 81 ! subroutine Agrif_Set_parent_real4 82 !--------------------------------------------------------------------------------------------------- 83 !> To set the parent value of a real variable 84 !--------------------------------------------------------------------------------------------------- 85 subroutine 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 90 integer :: i 91 logical :: i_found 92 93 i_found = .FALSE. 94 95 do 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 102 enddo 103 104 IF (.NOT.i_found) THEN 105 do 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 112 enddo 113 ENDIF 114 115 if (.NOT.i_found) STOP 'Agrif_Set_parent_real4 : Variable not found' 116 117 !--------------------------------------------------------------------------------------------------- 118 end subroutine Agrif_Set_parent_real4 119 !=================================================================================================== 120 ! 121 !=================================================================================================== 122 ! subroutine Agrif_Set_parent_real8 123 !--------------------------------------------------------------------------------------------------- 124 !> To set the parent value of a real variable 125 !--------------------------------------------------------------------------------------------------- 126 subroutine 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 131 integer :: i 132 logical :: i_found 133 134 i_found = .FALSE. 135 136 do 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 143 enddo 144 145 IF (.NOT.i_found) THEN 146 do 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 153 enddo 154 ENDIF 155 156 if (.NOT.i_found) STOP 'Agrif_Set_parent_real8 : Variable not found' 157 158 !--------------------------------------------------------------------------------------------------- 159 end subroutine Agrif_Set_parent_real8 160 !=================================================================================================== 161 ! 162 !=================================================================================================== 163 ! subroutine Agrif_Set_bc 164 !--------------------------------------------------------------------------------------------------- 165 subroutine Agrif_Set_bc ( tabvarsindic, bcinfsup, Interpolationshouldbemade ) 166 !--------------------------------------------------------------------------------------------------- 167 integer, intent(in) :: tabvarsindic !< indice of the variable in tabvars 168 integer, dimension(2), intent(in) :: bcinfsup !< bcinfsup 169 logical, optional, intent(in) :: Interpolationshouldbemade !< interpolation should be made 170 ! 171 integer :: indic ! indice of the variable in tabvars 172 type(Agrif_Variable), pointer :: var 173 ! 174 var => Agrif_Search_Variable(Agrif_Curgrid,tabvarsindic) 175 if (.not.associated(var)) return ! Grand mother grid case 176 ! 177 if ( Agrif_Curgrid % fixedrank /= 0 ) then 178 if ( .not.associated(var % oldvalues2D) ) then 179 allocate(var % oldvalues2D(2,1)) 180 var % interpIndex = -1 181 var % oldvalues2D = 0. 182 endif 183 if ( present(Interpolationshouldbemade) ) then 184 var % Interpolationshouldbemade = Interpolationshouldbemade 185 endif 186 endif 187 ! 188 var % bcinf = bcinfsup(1) 189 var % bcsup = bcinfsup(2) 190 !--------------------------------------------------------------------------------------------------- 191 end subroutine Agrif_Set_bc 192 !=================================================================================================== 193 ! 194 !=================================================================================================== 195 ! subroutine Agrif_Set_interp 196 !--------------------------------------------------------------------------------------------------- 197 subroutine Agrif_Set_interp ( tabvarsindic, interp, interp1, interp2, interp3 , interp4) 198 !--------------------------------------------------------------------------------------------------- 199 integer, intent(in) :: tabvarsindic !< indice of the variable in tabvars 200 integer, optional, intent(in) :: interp, interp1, interp2, interp3, interp4 201 ! 202 integer :: indic ! indice of the variable in tabvars 203 type(Agrif_Variable), pointer :: var 204 ! 205 var => Agrif_Search_Variable(Agrif_Curgrid,tabvarsindic) 206 if (.not.associated(var)) return ! Grand mother grid case 207 ! 208 var % type_interp = Agrif_Constant 209 ! 210 if (present(interp)) var % type_interp = interp 211 if (present(interp1)) var % type_interp(1) = interp1 212 if (present(interp2)) var % type_interp(2) = interp2 213 if (present(interp3)) var % type_interp(3) = interp3 214 if (present(interp4)) var % type_interp(4) = interp4 215 !--------------------------------------------------------------------------------------------------- 216 end subroutine Agrif_Set_interp 217 !=================================================================================================== 218 ! 219 !=================================================================================================== 220 ! subroutine Agrif_Set_bcinterp 221 !--------------------------------------------------------------------------------------------------- 222 subroutine Agrif_Set_bcinterp ( tabvarsindic, interp, interp1, interp2, interp3, interp4, & 223 interp11, interp12, interp21, interp22 ) 224 !--------------------------------------------------------------------------------------------------- 225 INTEGER, intent(in) :: tabvarsindic !< indice of the variable in tabvars 226 INTEGER, OPTIONAL, intent(in) :: interp, interp1, interp2, interp3, interp4 227 INTEGER, OPTIONAL, intent(in) :: interp11, interp12, interp21, interp22 228 ! 229 INTEGER :: indic ! indice of the variable in tabvars 230 TYPE(Agrif_Variable), pointer :: var 231 ! 232 var => Agrif_Search_Variable(Agrif_Curgrid,tabvarsindic) 233 ! 234 var % type_interp_bc = Agrif_Constant 235 ! 236 if (present(interp)) var % type_interp_bc = interp 237 if (present(interp1)) var % type_interp_bc(:,1) = interp1 238 if (present(interp11)) var % type_interp_bc(1,1) = interp11 239 if (present(interp12)) var % type_interp_bc(1,2) = interp12 240 if (present(interp2)) var % type_interp_bc(:,2) = interp2 241 if (present(interp21)) var % type_interp_bc(2,1) = interp21 242 if (present(interp22)) var % type_interp_bc(2,2) = interp22 243 if (present(interp3)) var % type_interp_bc(:,3) = interp3 244 if (present(interp4)) var % type_interp_bc(:,4) = interp4 245 !--------------------------------------------------------------------------------------------------- 246 end subroutine Agrif_Set_bcinterp 247 !=================================================================================================== 248 ! 249 !=================================================================================================== 250 ! subroutine Agrif_Set_UpdateType 251 !--------------------------------------------------------------------------------------------------- 252 subroutine Agrif_Set_UpdateType ( tabvarsindic, update, update1, update2, & 253 update3, update4, update5 ) 254 !--------------------------------------------------------------------------------------------------- 255 INTEGER, intent(in) :: tabvarsindic !< indice of the variable in tabvars 256 INTEGER, OPTIONAL, intent(in) :: update, update1, update2, update3, update4, update5 257 ! 258 INTEGER :: indic ! indice of the variable in tabvars 259 type(Agrif_Variable), pointer :: root_var 260 ! 261 262 root_var => Agrif_Search_Variable(Agrif_Mygrid,tabvarsindic) 263 264 ! 265 root_var % type_update = Agrif_Update_Copy 266 if (present(update)) root_var % type_update = update 267 if (present(update1)) root_var % type_update(1) = update1 268 if (present(update2)) root_var % type_update(2) = update2 269 if (present(update3)) root_var % type_update(3) = update3 270 if (present(update4)) root_var % type_update(4) = update4 271 if (present(update5)) root_var % type_update(5) = update5 272 !--------------------------------------------------------------------------------------------------- 273 end subroutine Agrif_Set_UpdateType 274 !=================================================================================================== 275 ! 45 276 !=================================================================================================== 46 277 ! subroutine Agrif_Set_restore 47 !> This subroutine is used to set the index of the current grid variable we want to restore.48 278 !--------------------------------------------------------------------------------------------------- 49 279 subroutine Agrif_Set_restore ( tabvarsindic ) … … 64 294 ! 65 295 !=================================================================================================== 296 ! subroutine Agrif_Init_variable 297 !--------------------------------------------------------------------------------------------------- 298 subroutine Agrif_Init_variable ( tabvarsindic, procname ) 299 !--------------------------------------------------------------------------------------------------- 300 INTEGER, intent(in) :: tabvarsindic !< indice of the variable in tabvars 301 procedure() :: procname !< Data recovery procedure 302 ! 303 if ( Agrif_Curgrid%level <= 0 ) return 304 ! 305 call Agrif_Interp_variable(tabvarsindic, procname) 306 call Agrif_Bc_variable(tabvarsindic, procname, 1.) 307 !--------------------------------------------------------------------------------------------------- 308 end subroutine Agrif_Init_variable 309 !=================================================================================================== 310 ! 311 !=================================================================================================== 312 ! subroutine Agrif_Bc_variable 313 !--------------------------------------------------------------------------------------------------- 314 subroutine Agrif_Bc_variable ( tabvarsindic, procname, calledweight ) 315 !--------------------------------------------------------------------------------------------------- 316 integer, intent(in) :: tabvarsindic !< indice of the variable in tabvars 317 procedure() :: procname 318 real, optional, intent(in) :: calledweight 319 ! 320 real :: weight 321 logical :: pweight 322 integer :: indic 323 integer :: nbdim 324 type(Agrif_Variable), pointer :: root_var 325 type(Agrif_Variable), pointer :: parent_var 326 type(Agrif_Variable), pointer :: child_var 327 type(Agrif_Variable), pointer :: child_tmp ! Temporary variable on the child grid 328 integer :: i 329 integer,dimension(7) :: lb, ub 330 ! 331 if ( Agrif_Curgrid%level <= 0 ) return 332 ! 333 ! 334 if ( present(calledweight) ) then 335 weight = calledweight 336 pweight = .true. 337 else 338 weight = 0. 339 pweight = .false. 340 endif 341 ! 342 child_var => Agrif_Search_Variable(Agrif_Curgrid,tabvarsindic) 343 parent_var => child_var % parent_var 344 root_var => child_var % root_var 345 ! 346 nbdim = root_var % nbdim 347 ! 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 358 select case( nbdim ) 359 case(1) 360 allocate(parray1(lb(1):ub(1))) 361 case(2) 362 allocate(parray2(lb(1):ub(1), & 363 lb(2):ub(2) )) 364 case(3) 365 allocate(parray3(lb(1):ub(1), & 366 lb(2):ub(2), & 367 lb(3):ub(3) )) 368 case(4) 369 allocate(parray4(lb(1):ub(1), & 370 lb(2):ub(2), & 371 lb(3):ub(3), & 372 lb(4):ub(4) )) 373 case(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) )) 379 case(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) )) 386 end select 387 ! 388 ! Create temporary child variable 389 allocate(child_tmp) 390 ! 391 child_tmp % root_var => root_var 392 child_tmp % oldvalues2D => child_var % oldvalues2D 393 ! 394 ! Index indicating if a space interpolation is necessary 395 child_tmp % interpIndex = child_var % interpIndex 396 child_tmp % list_interp => child_var % list_interp 397 child_tmp % Interpolationshouldbemade = child_var % Interpolationshouldbemade 398 ! 399 child_tmp % point = child_var % point 400 child_tmp % lb = child_var % lb 401 child_tmp % ub = child_var % ub 402 ! 403 child_tmp % bcinf = child_var % bcinf 404 child_tmp % bcsup = child_var % bcsup 405 ! 406 child_tmp % childarray = child_var % childarray 407 child_tmp % memberin = child_var % memberin 408 ! 409 call Agrif_CorrectVariable(parent_var, child_tmp, pweight, weight, procname) 410 ! 411 child_var % childarray = child_tmp % childarray 412 child_var % memberin = child_tmp % memberin 413 ! 414 child_var % oldvalues2D => child_tmp % oldvalues2D 415 child_var % list_interp => child_tmp % list_interp 416 ! 417 child_var % interpIndex = child_tmp % interpIndex 418 ! 419 deallocate(child_tmp) 420 ! 421 select case( nbdim ) 422 case(1); deallocate(parray1) 423 case(2); deallocate(parray2) 424 case(3); deallocate(parray3) 425 case(4); deallocate(parray4) 426 case(5); deallocate(parray5) 427 case(6); deallocate(parray6) 428 end select 429 !--------------------------------------------------------------------------------------------------- 430 end subroutine Agrif_Bc_variable 431 !=================================================================================================== 432 ! 433 !=================================================================================================== 434 ! subroutine Agrif_Interp_variable 435 !--------------------------------------------------------------------------------------------------- 436 subroutine Agrif_Interp_variable ( tabvarsindic, procname ) 437 !--------------------------------------------------------------------------------------------------- 438 integer, intent(in) :: tabvarsindic !< indice of the variable in tabvars 439 procedure() :: procname !< Data recovery procedure 440 ! 441 integer :: nbdim 442 integer :: indic ! indice of the variable in tabvars 443 logical :: torestore 444 type(Agrif_Variable), pointer :: root_var 445 type(Agrif_Variable), pointer :: parent_var ! Variable on the parent grid 446 type(Agrif_Variable), pointer :: child_var ! Variable on the parent grid 447 type(Agrif_Variable), pointer :: child_tmp ! Temporary variable on the child grid 448 ! 449 450 if ( Agrif_Curgrid%level <= 0 ) return 451 ! 452 453 child_var => Agrif_Search_Variable(Agrif_Curgrid,tabvarsindic) 454 parent_var => child_var % parent_var 455 root_var => child_var % root_var 456 457 ! 458 nbdim = root_var % nbdim 459 torestore = root_var % restore 460 ! 461 allocate(child_tmp) 462 ! 463 child_tmp % root_var => root_var 464 child_tmp % nbdim = root_var % nbdim 465 child_tmp % point = child_var % point 466 child_tmp % lb = child_var % lb 467 child_tmp % ub = child_var % ub 468 child_tmp % interpIndex = child_var % interpIndex 469 child_tmp % list_interp => child_var % list_interp 470 child_tmp % Interpolationshouldbemade = child_var % Interpolationshouldbemade 471 ! 472 if ( torestore ) then 473 select case( nbdim ) 474 case(1) 475 parray1 = child_var % array1 476 child_tmp % restore1D => child_var % restore1D 477 case(2) 478 parray2 = child_var % array2 479 child_tmp % restore2D => child_var % restore2D 480 case(3) 481 parray3 = child_var % array3 482 child_tmp % restore3D => child_var % restore3D 483 case(4) 484 parray4 = child_var % array4 485 child_tmp % restore4D => child_var % restore4D 486 case(5) 487 parray5 = child_var % array5 488 child_tmp % restore5D => child_var % restore5D 489 case(6) 490 parray6 = child_var % array6 491 child_tmp % restore6D => child_var % restore6D 492 end select 493 endif 494 ! 495 call Agrif_InterpVariable(parent_var, child_tmp, torestore, procname) 496 ! 497 child_var % list_interp => child_tmp % list_interp 498 ! 499 deallocate(child_tmp) 500 !--------------------------------------------------------------------------------------------------- 501 end subroutine Agrif_Interp_variable 502 !=================================================================================================== 503 ! 504 !=================================================================================================== 505 ! subroutine Agrif_Update_Variable 506 !--------------------------------------------------------------------------------------------------- 507 subroutine Agrif_Update_Variable ( tabvarsindic, procname, & 508 locupdate, locupdate1, locupdate2, locupdate3, locupdate4 ) 509 !--------------------------------------------------------------------------------------------------- 510 integer, intent(in) :: tabvarsindic !< Indice of the variable in tabvars 511 procedure() :: procname !< Data recovery procedure 512 integer, dimension(2), intent(in), optional :: locupdate 513 integer, dimension(2), intent(in), optional :: locupdate1 514 integer, dimension(2), intent(in), optional :: locupdate2 515 integer, dimension(2), intent(in), optional :: locupdate3 516 integer, dimension(2), intent(in), optional :: locupdate4 517 !--------------------------------------------------------------------------------------------------- 518 integer :: indic 519 integer :: nbdim 520 integer, dimension(6) :: updateinf ! First positions where interpolations are calculated 521 integer, dimension(6) :: updatesup ! Last positions where interpolations are calculated 522 type(Agrif_Variable), pointer :: root_var 523 type(Agrif_Variable), pointer :: parent_var 524 type(Agrif_Variable), pointer :: child_var 525 ! 526 if ( Agrif_Root() .AND. (.not.agrif_coarse) ) return 527 if (agrif_curgrid%grand_mother_grid) return 528 ! 529 530 child_var => Agrif_Search_Variable(Agrif_Curgrid, tabvarsindic) 531 parent_var => child_var % parent_var 532 533 if (.not.associated(parent_var)) then 534 ! can occur during the first update of Agrif_Coarsegrid (if any) 535 parent_var => Agrif_Search_Variable(Agrif_Curgrid % parent, tabvarsindic) 536 child_var % parent_var => parent_var 537 endif 538 539 root_var => child_var % root_var 540 541 ! 542 nbdim = root_var % nbdim 543 ! 544 updateinf = -99 545 updatesup = -99 546 ! 547 if ( present(locupdate) ) then 548 updateinf(1:nbdim) = locupdate(1) 549 updatesup(1:nbdim) = locupdate(2) 550 endif 551 ! 552 if ( present(locupdate1) ) then 553 updateinf(1) = locupdate1(1) 554 updatesup(1) = locupdate1(2) 555 endif 556 ! 557 if ( present(locupdate2) ) then 558 updateinf(2) = locupdate2(1) 559 updatesup(2) = locupdate2(2) 560 endif 561 562 if ( present(locupdate3) ) then 563 updateinf(3) = locupdate3(1) 564 updatesup(3) = locupdate3(2) 565 endif 566 567 if ( present(locupdate4) ) then 568 updateinf(4) = locupdate4(1) 569 updatesup(4) = locupdate4(2) 570 endif 571 ! 572 call Agrif_UpdateVariable( parent_var, child_var, updateinf, updatesup, procname ) 573 !--------------------------------------------------------------------------------------------------- 574 end subroutine Agrif_Update_Variable 575 !=================================================================================================== 576 ! 577 !=================================================================================================== 66 578 ! subroutine Agrif_Save_ForRestore0D 67 579 !--------------------------------------------------------------------------------------------------- 68 580 subroutine Agrif_Save_ForRestore0D ( tabvarsindic0, tabvarsindic ) 69 581 !--------------------------------------------------------------------------------------------------- 70 integer, intent(in) :: tabvarsindic0 !< index of the current grid variable 71 integer, intent(in) :: tabvarsindic !< index of the varible which should be restored 72 582 integer, intent(in) :: tabvarsindic0, tabvarsindic 73 583 ! 74 584 type(Agrif_Variable), pointer :: root_var, save_var … … 92 602 !=================================================================================================== 93 603 ! subroutine Agrif_Save_ForRestore2D 94 !> This function is used to restore a current grid variable (with the index tabvarsindic) to the input 2D-variable.95 604 !--------------------------------------------------------------------------------------------------- 96 605 subroutine Agrif_Save_ForRestore2D ( q, tabvarsindic ) 97 606 !--------------------------------------------------------------------------------------------------- 98 ! 99 real, dimension(:,:), intent(in) :: q !< input 2D-variable which should be saved 100 integer, intent(in) :: tabvarsindic !< index of the current grid variable we want to restore 607 real, dimension(:,:), intent(in) :: q 608 integer, intent(in) :: tabvarsindic 101 609 ! 102 610 type(Agrif_Variable), pointer :: root_var, save_var … … 133 641 !=================================================================================================== 134 642 ! subroutine Agrif_Save_ForRestore3D 135 !> This function is used to restore a current grid variable (with the index tabvarsindic) to the input 3D-variable.136 643 !--------------------------------------------------------------------------------------------------- 137 644 subroutine Agrif_Save_ForRestore3D ( q, tabvarsindic ) 138 645 !--------------------------------------------------------------------------------------------------- 139 ! 140 real, dimension(:,:,:), intent(in) :: q !< input 3D-variable which should be saved 141 integer, intent(in) :: tabvarsindic !< index of the current grid variable we want to restore 646 real, dimension(:,:,:), intent(in) :: q 647 integer, intent(in) :: tabvarsindic 142 648 ! 143 649 type(Agrif_Variable), pointer :: root_var, save_var … … 176 682 !=================================================================================================== 177 683 ! subroutine Agrif_Save_ForRestore4D 178 !> This function is used to restore a current grid variable (with the index tabvarsindic) to the input 4D-variable.179 684 !--------------------------------------------------------------------------------------------------- 180 685 subroutine Agrif_Save_ForRestore4D ( q, tabvarsindic ) 181 686 !--------------------------------------------------------------------------------------------------- 182 ! 183 real, dimension(:,:,:,:), intent(in) :: q !< input 4D-variable which should be saved 184 integer, intent(in) :: tabvarsindic !< index of the current grid variable we want to restore 185 ! 687 real, dimension(:,:,:,:), intent(in) :: q 688 integer, intent(in) :: tabvarsindic 186 689 ! 187 690 type(Agrif_Variable), pointer :: root_var, save_var -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modcluster.F90
r10087 r10725 29 29 module Agrif_Clustering 30 30 ! 31 !use Agrif_CurgridFunctions 32 !use Agrif_Init_Vars 33 !use Agrif_Save 31 use Agrif_CurgridFunctions 34 32 use Agrif_Init_Vars 35 33 use Agrif_Save 36 use Agrif_Init37 34 ! 38 35 implicit none … … 57 54 TYPE(Agrif_LRectangle), pointer :: parcours 58 55 TYPE(Agrif_Grid) , pointer :: newgrid 59 REAL (kind=8):: g_eps56 REAL :: g_eps 60 57 INTEGER :: i 61 58 ! … … 134 131 TYPE(Agrif_PGrid), pointer :: parcours 135 132 ! 136 REAL (kind=8):: g_eps, newgrid_eps, eps137 REAL (kind=8), DIMENSION(3) :: newmin, newmax138 REAL (kind=8), DIMENSION(3) :: gmin, gmax139 REAL (kind=8), DIMENSION(3) :: xmin133 REAL :: g_eps, newgrid_eps, eps 134 REAL , DIMENSION(3) :: newmin, newmax 135 REAL , DIMENSION(3) :: gmin, gmax 136 REAL , DIMENSION(3) :: xmin 140 137 INTEGER, DIMENSION(3) :: igmin, inewmin 141 138 INTEGER, DIMENSION(3) :: inewmax -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modcurgridfunctions.F90
r10087 r10725 29 29 implicit none 30 30 ! 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 31 41 contains 32 42 ! … … 92 102 ! 93 103 rhot = float(Agrif_IRhot()) 94 95 104 !--------------------------------------------------------------------------------------------------- 96 105 end function Agrif_Rhot … … 764 773 !=================================================================================================== 765 774 ! 775 776 function Agrif_Parent_Real_4(real_variable) result(real_variable_parent) 777 real(KIND=4) :: real_variable 778 real(KIND=4) :: real_variable_parent 779 780 integer :: i 781 logical :: i_found 782 783 i_found = .FALSE. 784 785 do i=1,Agrif_NbVariables(2) 786 if (LOC(real_variable) == LOC(agrif_curgrid%tabvars_r(i)%array0)) then 787 real_variable_parent = agrif_curgrid%tabvars_r(i)%parent_var%array0 788 i_found = .TRUE. 789 EXIT 790 endif 791 enddo 792 793 IF (.NOT.i_found) THEN 794 do i=1,Agrif_NbVariables(2) 795 if (LOC(real_variable) == LOC(agrif_curgrid%tabvars_r(i)%sarray0)) then 796 real_variable_parent = agrif_curgrid%tabvars_r(i)%parent_var%sarray0 797 i_found = .TRUE. 798 EXIT 799 endif 800 enddo 801 ENDIF 802 803 if (.NOT.i_found) STOP 'Agrif_Parent_Real_4 : Variable not found' 804 805 end function Agrif_Parent_Real_4 806 807 function Agrif_Parent_Real_8(real_variable) result(real_variable_parent) 808 real(KIND=8) :: real_variable 809 real(KIND=8) :: real_variable_parent 810 811 integer :: i 812 logical :: i_found 813 814 i_found = .FALSE. 815 816 do i=1,Agrif_NbVariables(2) 817 if (LOC(real_variable) == LOC(agrif_curgrid%tabvars_r(i)%array0)) then 818 real_variable_parent = agrif_curgrid%tabvars_r(i)%parent_var%array0 819 i_found = .TRUE. 820 EXIT 821 endif 822 enddo 823 824 IF (.NOT.i_found) THEN 825 do i=1,Agrif_NbVariables(2) 826 if (LOC(real_variable) == LOC(agrif_curgrid%tabvars_r(i)%darray0)) then 827 real_variable_parent = agrif_curgrid%tabvars_r(i)%parent_var%darray0 828 i_found = .TRUE. 829 EXIT 830 endif 831 enddo 832 ENDIF 833 834 if (.NOT.i_found) STOP 'Agrif_Parent_Real_8 : Variable not found' 835 836 end function Agrif_Parent_Real_8 837 838 function Agrif_Parent_Array2_Real_8(real_variable,ji,jj) result(real_variable_parent) 839 real(KIND=8), DIMENSION(:,:) :: real_variable 840 real(KIND=8) :: real_variable_parent 841 integer :: ji,jj 842 843 integer :: i 844 logical :: i_found 845 846 i_found = .FALSE. 847 848 do i=1,Agrif_NbVariables(0) 849 if (LOC(real_variable) == LOC(agrif_curgrid%tabvars(i)%array2)) then 850 real_variable_parent = agrif_curgrid%tabvars(i)%parent_var%array2(ji,jj) 851 i_found = .TRUE. 852 EXIT 853 endif 854 enddo 855 856 if (.NOT.i_found) STOP 'Agrif_Parent_Array2_Real_8 : Variable not found' 857 858 end function Agrif_Parent_Array2_Real_8 859 860 861 function Agrif_Parent_Integer(integer_variable) result(integer_variable_parent) 862 integer :: integer_variable 863 integer :: integer_variable_parent 864 865 integer :: i 866 logical :: i_found 867 868 i_found = .FALSE. 869 870 do i=1,Agrif_NbVariables(4) 871 if (LOC(integer_variable) == LOC(agrif_curgrid%tabvars_i(i)%iarray0)) then 872 integer_variable_parent = agrif_curgrid%tabvars_i(i)%parent_var%iarray0 873 i_found = .TRUE. 874 EXIT 875 endif 876 enddo 877 878 if (.NOT.i_found) STOP 'Agrif_Parent : Variable not found' 879 880 end function Agrif_Parent_Integer 881 882 function Agrif_Parent_Character(character_variable) result(character_variable_parent) 883 character(*) :: character_variable 884 character(len(character_variable)) :: character_variable_parent 885 886 integer :: i 887 logical :: i_found 888 889 i_found = .FALSE. 890 891 do i=1,Agrif_NbVariables(1) 892 if (LOC(character_variable) == LOC(agrif_curgrid%tabvars_c(i)%carray0)) then 893 character_variable_parent = agrif_curgrid%tabvars_c(i)%parent_var%carray0 894 i_found = .TRUE. 895 EXIT 896 endif 897 enddo 898 899 if (.NOT.i_found) STOP 'Agrif_Parent : Variable not found' 900 901 end function Agrif_Parent_Character 902 903 function Agrif_Parent_Logical(logical_variable) result(logical_variable_parent) 904 logical :: logical_variable 905 logical :: logical_variable_parent 906 907 integer :: i 908 logical :: i_found 909 910 i_found = .FALSE. 911 912 do i=1,Agrif_NbVariables(3) 913 if (LOC(logical_variable) == LOC(agrif_curgrid%tabvars_l(i)%larray0)) then 914 logical_variable_parent = agrif_curgrid%tabvars_l(i)%parent_var%larray0 915 i_found = .TRUE. 916 EXIT 917 endif 918 enddo 919 920 if (.NOT.i_found) STOP 'Agrif_Parent : Variable not found' 921 922 end function Agrif_Parent_Logical 923 924 function Agrif_Irhox() result(i_val) 925 integer :: i_val 926 i_val = agrif_curgrid%spaceref(1) 927 end function Agrif_Irhox 928 929 function Agrif_Irhoy() result(i_val) 930 integer :: i_val 931 i_val = agrif_curgrid%spaceref(2) 932 end function Agrif_Irhoy 933 934 function Agrif_Irhoz() result(i_val) 935 integer :: i_val 936 i_val = agrif_curgrid%spaceref(3) 937 end function Agrif_Irhoz 938 939 function Agrif_NearCommonBorderX() result(l_val) 940 logical :: l_val 941 l_val = agrif_curgrid%nearRootBorder(1) 942 end function Agrif_NearCommonBorderX 943 944 function Agrif_NearCommonBorderY() result(l_val) 945 logical :: l_val 946 l_val = agrif_curgrid%nearRootBorder(2) 947 end function Agrif_NearCommonBorderY 948 949 function Agrif_NearCommonBorderZ() result(l_val) 950 logical :: l_val 951 l_val = agrif_curgrid%nearRootBorder(3) 952 end function Agrif_NearCommonBorderZ 953 954 function Agrif_DistantCommonBorderX() result(l_val) 955 logical :: l_val 956 l_val = agrif_curgrid%DistantRootBorder(1) 957 end function Agrif_DistantCommonBorderX 958 959 function Agrif_DistantCommonBorderY() result(l_val) 960 logical :: l_val 961 l_val = agrif_curgrid%DistantRootBorder(2) 962 end function Agrif_DistantCommonBorderY 963 964 function Agrif_DistantCommonBorderZ() result(l_val) 965 logical :: l_val 966 l_val = agrif_curgrid%DistantRootBorder(3) 967 end function Agrif_DistantCommonBorderZ 968 969 function Agrif_Ix() result(i_val) 970 integer :: i_val 971 i_val = agrif_curgrid%ix(1) 972 end function Agrif_Ix 973 974 function Agrif_Iy() result(i_val) 975 integer :: i_val 976 i_val = agrif_curgrid%ix(2) 977 end function Agrif_Iy 978 979 function Agrif_Iz() result(i_val) 980 integer :: i_val 981 i_val = agrif_curgrid%ix(3) 982 end function Agrif_Iz 983 984 function Agrif_Get_grid_id() result(i_val) 985 integer :: i_val 986 i_val = agrif_curgrid % grid_id 987 end function Agrif_Get_grid_id 988 989 function Agrif_Get_parent_id() result(i_val) 990 integer :: i_val 991 i_val = agrif_curgrid % parent % grid_id 992 end function Agrif_Get_parent_id 993 994 function Agrif_rhox() result(r_val) 995 real :: r_val 996 r_val = real(agrif_curgrid%spaceref(1)) 997 end function Agrif_rhox 998 999 function Agrif_rhoy() result(r_val) 1000 real :: r_val 1001 r_val = real(agrif_curgrid%spaceref(2)) 1002 end function Agrif_rhoy 1003 1004 function Agrif_rhoz() result(r_val) 1005 real :: r_val 1006 r_val = real(agrif_curgrid%spaceref(3)) 1007 end function Agrif_rhoz 1008 1009 function Agrif_Nb_Step() result(i_val) 1010 integer :: i_val 1011 i_val = agrif_curgrid%ngridstep 1012 end function Agrif_Nb_Step 1013 1014 function Agrif_Nb_Fine_Grids() result(i_val) 1015 integer :: i_val 1016 i_val = Agrif_nbfixedgrids 1017 end function Agrif_Nb_Fine_Grids 1018 766 1019 end module Agrif_CurgridFunctions -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modgrids.F90
r10087 r10725 44 44 type(Agrif_Variable_i), dimension(:), allocatable :: tabvars_i !< List of integer grid variables 45 45 ! 46 real (kind=8), dimension(3):: Agrif_x !< global x, y and z position47 real (kind=8) , dimension(3):: Agrif_dx !< global space step in the x, y and z direction48 real , dimension(3):: Agrif_dt !< global time step in the x, y and z direction46 real , dimension(3) :: Agrif_x !< global x, y and z position 47 real , dimension(3) :: Agrif_dx !< global space step in the x, y and z direction 48 real , dimension(3) :: Agrif_dt !< global time step in the x, y and z direction 49 49 integer, dimension(3) :: nb !< number of cells in the x, y and z direction 50 50 integer, dimension(3) :: ix !< minimal position in the x, y and z direction -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modinit.F90
r10087 r10725 31 31 ! 32 32 implicit none 33 34 abstract interface35 subroutine step_proc()36 end subroutine step_proc37 end interface38 39 33 ! 40 34 contains 41 35 ! 42 43 44 subroutine Agrif_call_procname ( procname )45 procedure(step_proc) :: procname46 call procname()47 end subroutine Agrif_call_procname48 !===================================================================================================49 50 subroutine Agrif_call_procname1 ( procname1 )51 procedure(typedef_proc) :: procname152 call procname1()53 end subroutine Agrif_call_procname154 55 36 !=================================================================================================== 56 37 ! subroutine Agrif_Allocation -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modinterp.F90
r10087 r10725 26 26 module Agrif_Interpolation 27 27 ! 28 use Agrif_Init 29 use Agrif_Arrays 30 use Agrif_InterpBasic 31 use Agrif_User_Functions 32 28 use Agrif_InterpBasic 29 use Agrif_Arrays 30 use Agrif_Mask 31 use Agrif_CurgridFunctions 33 32 #if defined AGRIF_MPI 34 33 use Agrif_Mpp 35 34 #endif 36 37 use Agrif_Mask38 35 ! 39 36 implicit none … … 69 66 integer, dimension(6) :: ub_child 70 67 integer, dimension(6) :: lb_parent 71 real (kind=8), dimension(6) :: s_child, s_parent72 real (kind=8), dimension(6) :: ds_child, ds_parent68 real , dimension(6) :: s_child, s_parent 69 real , dimension(6) :: ds_child, ds_parent 73 70 integer, dimension(child % root_var % nbdim,2,2) :: childarray 74 71 ! … … 118 115 INTEGER, DIMENSION(nbdim), INTENT(in) :: pttab_Parent !< Index of the first point inside the domain 119 116 !< for the parent grid variable 120 REAL (kind=8), DIMENSION(nbdim), INTENT(in) :: s_Child,s_Parent !< Positions of the parent and child grids121 REAL (kind=8), DIMENSION(nbdim), INTENT(in) :: ds_Child,ds_Parent !< Space steps of the parent and child grids117 REAL, DIMENSION(nbdim), INTENT(in) :: s_Child,s_Parent !< Positions of the parent and child grids 118 REAL, DIMENSION(nbdim), INTENT(in) :: ds_Child,ds_Parent !< Space steps of the parent and child grids 122 119 TYPE(Agrif_Variable), pointer :: restore !< Indicates points where interpolation 123 120 LOGICAL, INTENT(in) :: torestore !< Indicates if the array restore is used … … 131 128 INTEGER :: i,j,k,l,m,n 132 129 INTEGER, DIMENSION(nbdim) :: pttruetab,cetruetab 133 INTEGER, DIMENSION(nbdim) :: indmin, indmax , indmin_required_p, indmax_required_p130 INTEGER, DIMENSION(nbdim) :: indmin, indmax 134 131 INTEGER, DIMENSION(nbdim) :: indminglob, indmaxglob 135 132 #if defined AGRIF_MPI … … 138 135 #endif 139 136 LOGICAL, DIMENSION(nbdim) :: noraftab 140 REAL (kind=8) , DIMENSION(nbdim) :: s_Child_temp,s_Parent_temp,s_Parent_temp_p137 REAL , DIMENSION(nbdim) :: s_Child_temp,s_Parent_temp 141 138 INTEGER, DIMENSION(nbdim) :: lowerbound, upperbound, coords 142 139 INTEGER, DIMENSION(nbdim,2,2), INTENT(OUT) :: childarray … … 174 171 child % list_interp, & 175 172 pttab, petab, pttab_Child, pttab_Parent, nbdim, & 176 indmin, indmax, indmin_required_p, indmax_required_p, & 177 indminglob, indmaxglob, & 173 indmin, indmax, indminglob, indmaxglob, & 178 174 pttruetab, cetruetab, memberin & 179 175 #if defined AGRIF_MPI … … 182 178 #endif 183 179 ) 184 185 180 ! 186 181 if (.not.find_list_interp) then 187 182 ! 188 ! output : lowerbound and upperbound are the (local) lower and upper bounds of the child arrays189 190 183 call Agrif_get_var_bounds_array(child, lowerbound, upperbound, nbdim) 191 192 ! input : pttab, petab : global indexes where the interpolation is required193 ! output : pttruetab, cetruetab : global indexes restricted to the bounds of the current processor194 ! output : memberin is false if the current processor is not involved in the interpolation195 196 184 call Agrif_Childbounds(nbdim, lowerbound, upperbound, & 197 185 pttab, petab, Agrif_Procrank, coords, & 198 186 pttruetab, cetruetab, memberin) 199 200 201 202 ! output : indminglob, indmaxglob : global indexes required on the parent grid for the interpolation203 ! output : s_Parent_temp, s_Child_temp : local s_Parent, s_Child relatively to indmin ou pttab204 187 call Agrif_Parentbounds(type_interp,nbdim,indminglob,indmaxglob, & 205 indmin_required_p, indmax_required_p, &206 188 s_Parent_temp,s_Child_temp, & 207 189 s_Child,ds_Child, & … … 212 194 #if defined AGRIF_MPI 213 195 if (memberin) then 214 215 ! output : indmin, indmax : global indexes required on the parent grid for the interpolation on the current processor (i.e. on pttruetab, cetruetab)216 ! output : s_Parent_temp, s_Child_temp : local s_Parent, s_Child relatively to indmin ou pttruetab217 196 call Agrif_Parentbounds(type_interp,nbdim,indmin,indmax, & 218 indmin_required_p, indmax_required_p, &219 197 s_Parent_temp,s_Child_temp, & 220 198 s_Child,ds_Child, & … … 226 204 227 205 local_proc = Agrif_Procrank 228 229 ! output : lowerbound and upperbound are the (local) lower and upper bounds of the parent arrays230 206 call Agrif_get_var_bounds_array(parent,lowerbound,upperbound,nbdim) 231 207 call Agrif_ChildGrid_to_ParentGrid() 232 233 ! input : indminglob,indmaxglob : global indexes where data are required for the interpolation 234 ! output : indminglob2,indmaxglob2 : global indexes restricted to the bounds of the current processor 235 ! output : member is false if the current processor does not need to send data 236 ! output : indminglob3,indmaxglob3 : global bounds on the current processor for the parent array 237 208 ! 238 209 call Agrif_Childbounds(nbdim,lowerbound,upperbound, & 239 210 indminglob,indmaxglob, local_proc, coords, & … … 242 213 ! 243 214 if (member) then 244 245 ! output : parentarray246 ! output : parentarray (:,:,2) : indminglob2, indmaxglob2 in term of local indexes on current processor247 ! output : parentarray (:,:,1) : indminglob2, indmaxglob2 restricted to the current processor (different from indminglob2 ???)248 ! output : member is .false. is the current processor has not data to send249 250 215 call Agrif_GlobalToLocalBounds(parentarray, & 251 216 lowerbound, upperbound, & … … 256 221 call Agrif_ParentGrid_to_ChildGrid() 257 222 #else 258 259 ! In the sequentiel case, the following lines ensure that the bounds needed on the parent grid in the interpolation260 ! do not exceed lower and upper bounds of the parent array261 262 ! output : lowerbound and upperbound are the (local) lower and upper bounds of the parent arrays263 call Agrif_get_var_bounds_array(parent,lowerbound,upperbound,nbdim)264 call Agrif_ChildGrid_to_ParentGrid()265 266 ! input : indminglob,indmaxglob : global indexes where data are required for the interpolation267 ! output : indminglob2,indmaxglob2 : global indexes restricted to the bounds of the current processor268 ! output : member is false if the current processor does not need to send data269 270 call Agrif_Childbounds(nbdim,lowerbound,upperbound, &271 indminglob,indmaxglob, Agrif_Procrank, coords, &272 indmin,indmax,member)273 274 call Agrif_ParentGrid_to_ChildGrid()275 276 indminglob = indmin277 indmaxglob = indmax278 279 223 parentarray(:,1,1) = indminglob 280 224 parentarray(:,2,1) = indmaxglob 281 225 parentarray(:,1,2) = indminglob 282 226 parentarray(:,2,2) = indmaxglob 283 284 ! indmin = indminglob 285 ! indmax = indmaxglob 286 227 indmin = indminglob 228 indmax = indmaxglob 287 229 member = .TRUE. 288 s_Parent_temp = s_Parent + (indminglob - pttab_Parent) * ds_Parent289 290 230 #endif 291 231 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! … … 307 247 s_Child_temp = s_Child + (pttruetab - pttab_Child) * ds_Child 308 248 #else 309 310 ! In the sequentiel case, the following lines ensure that the bounds needed on the parent grid in the interpolation311 ! do not exceed lower and upper bounds of the parent array312 313 ! output : lowerbound and upperbound are the (local) lower and upper bounds of the parent arrays314 call Agrif_get_var_bounds_array(parent,lowerbound,upperbound,nbdim)315 call Agrif_ChildGrid_to_ParentGrid()316 317 ! input : indminglob,indmaxglob : global indexes where data are required for the interpolation318 ! output : indminglob2,indmaxglob2 : global indexes restricted to the bounds of the current processor319 ! output : member is false if the current processor does not need to send data320 321 call Agrif_Childbounds(nbdim,lowerbound,upperbound, &322 indminglob,indmaxglob, Agrif_Procrank, coords, &323 indmin,indmax,member)324 325 call Agrif_ParentGrid_to_ChildGrid()326 327 indminglob = indmin328 indmaxglob = indmax329 330 249 parentarray(:,1,1) = indminglob 331 250 parentarray(:,2,1) = indmaxglob 332 251 parentarray(:,1,2) = indminglob 333 252 parentarray(:,2,2) = indmaxglob 334 !indmin = indminglob335 !indmax = indmaxglob253 indmin = indminglob 254 indmax = indmaxglob 336 255 member = .TRUE. 337 256 s_Parent_temp = s_Parent + (indminglob - pttab_Parent) * ds_Parent … … 343 262 if (.not.associated(tempP)) allocate(tempP) 344 263 ! 345 346 264 call Agrif_array_allocate(tempP,parentarray(:,1,1),parentarray(:,2,1),nbdim) 347 265 call Agrif_var_set_array_tozero(tempP,nbdim) … … 384 302 parentarray(6,1,2),parentarray(6,2,2),.TRUE.,nb,ndir) 385 303 end select 386 387 304 ! 388 305 call Agrif_ParentGrid_to_ChildGrid() … … 443 360 child%list_interp,pttab,petab, & 444 361 pttab_Child,pttab_Parent,indmin,indmax, & 445 indmin_required_p, indmax_required_p, &446 362 indminglob,indmaxglob, & 447 363 pttruetab,cetruetab, & … … 456 372 endif 457 373 ! 458 459 374 if (memberin) then 460 375 ! 461 376 if (.not.associated(tempC)) allocate(tempC) 462 377 ! 463 464 378 call Agrif_array_allocate(tempC,pttruetab,cetruetab,nbdim) 465 466 379 ! 467 380 ! Special values on the parent grid … … 471 384 ! 472 385 if (.not.associated(parentvalues)) allocate(parentvalues) 473 !t 474 386 ! 475 387 call Agrif_array_allocate(parentvalues,indmin,indmax,nbdim) 476 388 call Agrif_var_full_copy_array(parentvalues,tempPextend,nbdim) 477 389 ! 478 call Agrif_CheckMasknD(tempPextend,parentvalues, & 479 indmin(1:nbdim),indmax(1:nbdim), & 480 indmin(1:nbdim),indmax(1:nbdim), & 481 indmin_required_p(1:nbdim),indmax_required_p(1:nbdim), & 390 call Agrif_CheckMasknD(tempPextend,parentvalues, & 391 indmin(1:nbdim),indmax(1:nbdim), & 392 indmin(1:nbdim),indmax(1:nbdim), & 482 393 noraftab(1:nbdim),nbdim) 483 394 ! … … 507 418 ds_Child(1:2), ds_Parent(1:2) ) 508 419 case(3) 509 s_Parent_temp_p = s_Parent + (indmin_required_p - pttab_Parent) * ds_Parent 510 call Agrif_Interp_3D_recursive( type_interp(1:3), & 511 tempPextend % array3( & 512 indmin_required_p(1):indmax_required_p(1), & 513 indmin_required_p(2):indmax_required_p(2), & 514 indmin_required_p(3):indmax_required_p(3)), & 515 tempC % array3, & 516 indmin_required_p(1:3), indmax_required_p(1:3), & 517 pttruetab(1:3), cetruetab(1:3), & 518 s_Child_temp(1:3), s_Parent_temp_p(1:3), & 420 call Agrif_Interp_3D_recursive( type_interp(1:3), & 421 tempPextend % array3, & 422 tempC % array3, & 423 indmin(1:3), indmax(1:3), & 424 pttruetab(1:3), cetruetab(1:3), & 425 s_Child_temp(1:3), s_Parent_temp(1:3), & 519 426 ds_Child(1:3), ds_Parent(1:3) ) 520 521 427 case(4) 522 s_Parent_temp_p = s_Parent + (indmin_required_p - pttab_Parent) * ds_Parent 523 call Agrif_Interp_4D_recursive( type_interp(1:4), & 524 tempPextend % array4( & 525 indmin_required_p(1):indmax_required_p(1), & 526 indmin_required_p(2):indmax_required_p(2), & 527 indmin_required_p(3):indmax_required_p(3), & 528 indmin_required_p(4):indmax_required_p(4)), & 529 tempC % array4, & 530 indmin_required_p(1:4), indmax_required_p(1:4), & 531 pttruetab(1:4), cetruetab(1:4), & 532 s_Child_temp(1:4), s_Parent_temp_p(1:4), & 428 call Agrif_Interp_4D_recursive( type_interp(1:4), & 429 tempPextend % array4, & 430 tempC % array4, & 431 indmin(1:4), indmax(1:4), & 432 pttruetab(1:4), cetruetab(1:4), & 433 s_Child_temp(1:4), s_Parent_temp(1:4), & 533 434 ds_Child(1:4), ds_Parent(1:4) ) 534 435 case(5) … … 721 622 else ! .not.to_restore 722 623 ! 723 724 624 if (memberin) then 725 625 ! … … 842 742 endif 843 743 844 845 744 call Agrif_array_deallocate(tempPextend,nbdim) 846 745 call Agrif_array_deallocate(tempC,nbdim) … … 864 763 !--------------------------------------------------------------------------------------------------- 865 764 subroutine Agrif_Parentbounds ( type_interp, nbdim, indmin, indmax, & 866 indmin_required,indmax_required, &867 765 s_Parent_temp, s_Child_temp, & 868 766 s_Child, ds_Child, & … … 874 772 INTEGER, intent(in) :: nbdim 875 773 INTEGER, DIMENSION(nbdim), intent(out) :: indmin, indmax 876 INTEGER, DIMENSION(nbdim), intent(out) :: indmin_required, indmax_required 877 REAL(kind=8), DIMENSION(nbdim), intent(out) :: s_Parent_temp, s_child_temp 878 REAL(kind=8), DIMENSION(nbdim), intent(in) :: s_Child, ds_child 879 REAL(kind=8), DIMENSION(nbdim), intent(in) :: s_Parent,ds_Parent 774 REAL, DIMENSION(nbdim), intent(out) :: s_Parent_temp, s_child_temp 775 REAL, DIMENSION(nbdim), intent(in) :: s_Child, ds_child 776 REAL, DIMENSION(nbdim), intent(in) :: s_Parent,ds_Parent 880 777 INTEGER, DIMENSION(nbdim), intent(in) :: pttruetab, cetruetab 881 778 INTEGER, DIMENSION(nbdim), intent(in) :: pttab_Child, pttab_Parent … … 883 780 INTEGER, DIMENSION(nbdim), intent(in) :: coords 884 781 ! 885 REAL(kind=8) :: xpmin, xpmax886 INTEGER :: coeffraf887 782 INTEGER :: i 888 REAL (kind=8),DIMENSION(nbdim) :: dim_newmin, dim_newmax783 REAL,DIMENSION(nbdim) :: dim_newmin, dim_newmax 889 784 ! 890 785 dim_newmin = s_Child + (pttruetab - pttab_Child) * ds_Child … … 895 790 indmin(i) = pttab_Parent(i) + agrif_int((dim_newmin(i)-s_Parent(i))/ds_Parent(i)) 896 791 indmax(i) = pttab_Parent(i) + agrif_ceiling((dim_newmax(i)-s_Parent(i))/ds_Parent(i)) 897 898 coeffraf = nint(ds_Parent(i)/ds_Child(i))899 900 indmin_required(i) = indmin(i)901 indmax_required(i) = indmax(i)902 792 ! 903 793 ! Necessary for the Quadratic interpolation 904 794 ! 905 906 795 if ( (pttruetab(i) == cetruetab(i)) .and. (posvar(i) == 1) ) then 907 if (Agrif_UseSpecialValue) then908 indmin(i) = indmin(i)-MaxSearch909 indmax(i) = indmax(i)+MaxSearch910 endif911 796 elseif ( coords(i) == 0 ) then ! (interptab == 'N') 912 797 elseif ( (type_interp(i) == Agrif_ppm) .or. & … … 914 799 (type_interp(i) == Agrif_ppm_lim) .or. & 915 800 (type_interp(i) == Agrif_weno) ) then 916 917 if ((mod(coeffraf,2) == 0).AND.(posvar(i)==2)) then 918 919 xpmax = s_Parent(i)+(indmax(i)-pttab_Parent(i))*ds_Parent(i) 920 if (xpmax > dim_newmax(i)+ds_Child(i)) then 921 indmax(i) = indmax(i) + 1 922 else 923 indmax(i) = indmax(i) + 2 924 endif 925 926 xpmin = s_Parent(i)+(indmin(i)-pttab_Parent(i))*ds_Parent(i) 927 if (xpmin < dim_newmin(i)-ds_Child(i)) then 928 indmin(i) = indmin(i) - 1 929 else 930 indmin(i) = indmin(i) - 2 931 endif 932 933 else 934 indmin(i) = indmin(i) - 2 935 indmax(i) = indmax(i) + 2 936 endif 937 938 indmin_required(i) = indmin(i) 939 indmax_required(i) = indmax(i) 940 941 if (Agrif_UseSpecialValue) then 942 indmin(i) = indmin(i)-MaxSearch 943 indmax(i) = indmax(i)+MaxSearch 944 endif 945 elseif (type_interp(i) == Agrif_linearconservlim) then 946 947 if ((mod(coeffraf,2) == 0).AND.(posvar(i)==2)) then 948 949 xpmax = s_Parent(i)+(indmax(i)-pttab_Parent(i))*ds_Parent(i) 950 if (xpmax > dim_newmax(i)+ds_Child(i)) then 951 indmax(i) = indmax(i) 952 else 953 indmax(i) = indmax(i) + 1 954 endif 955 956 xpmin = s_Parent(i)+(indmin(i)-pttab_Parent(i))*ds_Parent(i) 957 if (xpmin < dim_newmin(i)-ds_Child(i)) then 958 indmin(i) = indmin(i) 959 else 960 indmin(i) = indmin(i) - 1 961 endif 962 963 else 964 indmin(i) = indmin(i) - 1 965 indmax(i) = indmax(i) + 1 966 endif 967 968 indmin_required(i) = indmin(i) 969 indmax_required(i) = indmax(i) 970 971 if (Agrif_UseSpecialValue) then 972 indmin(i) = indmin(i)-MaxSearch 973 indmax(i) = indmax(i)+MaxSearch 974 endif 975 801 indmin(i) = indmin(i) - 2 802 indmax(i) = indmax(i) + 2 976 803 elseif ( (type_interp(i) /= Agrif_constant) .and. & 977 804 (type_interp(i) /= Agrif_linear) ) then 978 805 indmin(i) = indmin(i) - 1 979 806 indmax(i) = indmax(i) + 1 980 981 indmin_required(i) = indmin(i)982 indmax_required(i) = indmax(i)983 984 if (Agrif_UseSpecialValue) then985 indmin(i) = indmin(i)-MaxSearch986 indmax(i) = indmax(i)+MaxSearch987 endif988 elseif ( (type_interp(i) == Agrif_constant) .or. &989 (type_interp(i) == Agrif_linear) ) then990 indmin_required(i) = indmin(i)991 indmax_required(i) = indmax(i)992 if (Agrif_UseSpecialValue) then993 indmin(i) = indmin(i)-MaxSearch994 indmax(i) = indmax(i)+MaxSearch995 endif996 807 endif 997 998 808 ! 999 809 enddo … … 1020 830 integer, intent(in) :: indmin, indmax 1021 831 integer, intent(in) :: pttab_child, petab_child 1022 real (kind=8), intent(in) :: s_child, s_parent1023 real (kind=8), intent(in) :: ds_child, ds_parent832 real, intent(in) :: s_child, s_parent 833 real, intent(in) :: ds_child, ds_parent 1024 834 real, dimension( & 1025 835 indmin:indmax & … … 1055 865 integer, dimension(2), intent(in) :: indmin, indmax 1056 866 integer, dimension(2), intent(in) :: pttab_child, petab_child 1057 real (kind=8), dimension(2), intent(in) :: s_child, s_parent1058 real (kind=8), dimension(2), intent(in) :: ds_child, ds_parent867 real, dimension(2), intent(in) :: s_child, s_parent 868 real, dimension(2), intent(in) :: ds_child, ds_parent 1059 869 real, dimension( & 1060 870 indmin(1):indmax(1), & … … 1073 883 indmin(2):indmax(2), & 1074 884 pttab_child(1):petab_child(1)) :: tabtemp_trsp 1075 integer :: i, j, coeffraf , locind_child_left, ideb885 integer :: i, j, coeffraf 1076 886 !--------------------------------------------------------------------------------------------------- 1077 887 ! … … 1098 908 s_parent(1),s_child(1),ds_parent(1),ds_child(1),1) 1099 909 !---CDIR NEXPAND 1100 call PPM1dAfterCompute(tabin,tabtemp,size(tabin),size(tabtemp),1,indchildppm(:,1),tabppm(:,:,1)) 1101 else if (coeffraf == 1) then 1102 locind_child_left = indmin(1) + agrif_int((s_child(1)-s_parent(1))/ds_parent(1)) 1103 1104 do j = indmin(2), indmax(2) 1105 ideb = locind_child_left 1106 do i = pttab_child(1), petab_child(1) 1107 tabtemp(i,j) = tabin(ideb,j) 1108 ideb = ideb + 1 1109 enddo 1110 enddo 1111 910 call PPM1dAfterCompute(tabin,tabtemp,size(tabin),size(tabtemp),1) 1112 911 else 1113 912 do j = indmin(2),indmax(2) … … 1150 949 !---CDIR NEXPAND 1151 950 call PPM1dAfterCompute(tabtemp_trsp, tabout_trsp, & 1152 size(tabtemp_trsp), size(tabout_trsp), 2, & 1153 indchildppm(:,2),tabppm(:,:,2)) 951 size(tabtemp_trsp), size(tabout_trsp), 2) 1154 952 else 1155 953 do i = pttab_child(1), petab_child(1) … … 1186 984 integer, dimension(3), intent(in) :: indmin, indmax 1187 985 integer, dimension(3), intent(in) :: pttab_child, petab_child 1188 real (kind=8), dimension(3), intent(in) :: s_child, s_parent1189 real (kind=8), dimension(3), intent(in) :: ds_child, ds_parent986 real, dimension(3), intent(in) :: s_child, s_parent 987 real, dimension(3), intent(in) :: ds_child, ds_parent 1190 988 real, dimension( & 1191 989 indmin(1):indmax(1), & … … 1201 999 pttab_child(2):petab_child(2), & 1202 1000 indmin(3):indmax(3)) :: tabtemp 1203 integer :: i, j, k, coeffraf ,kp,kp1,kp2,kp3,kp4,kref1001 integer :: i, j, k, coeffraf 1204 1002 integer :: locind_child_left, kdeb 1205 real(kind=8) :: ypos,globind_parent_left1206 real(kind=8) :: deltax, invdsparent1207 real :: t2,t3,t4,t5,t6,t7,t81208 integer :: locind_parent_left1209 1210 1003 ! 1211 1004 coeffraf = nint ( ds_parent(1) / ds_child(1) ) … … 1266 1059 enddo 1267 1060 enddo 1268 else if (type_interp(3) == Agrif_LAGRANGE) then1269 invdsparent = 1./ds_parent(3)1270 ypos = s_child(3)1271 do k=pttab_child(3), petab_child(3)1272 locind_parent_left = indmin(3)+agrif_int((ypos - s_parent(3))/ds_parent(3))1273 globind_parent_left = s_parent(3) + (locind_parent_left - indmin(3))*ds_parent(3)1274 deltax = invdsparent*(ypos-globind_parent_left)1275 deltax = nint(coeffraf*deltax)/real(coeffraf)1276 ypos = ypos + ds_child(3)1277 1278 if (abs(deltax) <= 0.0001) then1279 do j = pttab_child(2), petab_child(2)1280 do i = pttab_child(1), petab_child(1)1281 tabout(i,j,k) = tabtemp(i,j,locind_parent_left)1282 enddo1283 enddo1284 else1285 t2 = deltax - 2.1286 t3 = deltax - 1.1287 t4 = deltax + 1.1288 1289 t5 = -(1./6.)*deltax*t2*t31290 t6 = 0.5*t2*t3*t41291 t7 = -0.5*deltax*t2*t41292 t8 = (1./6.)*deltax*t3*t41293 do j = pttab_child(2), petab_child(2)1294 do i = pttab_child(1), petab_child(1)1295 tabout(i,j,k) = t5*tabtemp(i,j,locind_parent_left-1) + t6*tabtemp(i,j,locind_parent_left) &1296 +t7*tabtemp(i,j,locind_parent_left+1) + t8*tabtemp(i,j,locind_parent_left+2)1297 enddo1298 enddo1299 1300 endif1301 1302 enddo1303 else if (type_interp(3) == Agrif_PPM) then1304 call PPM1dPrecompute2d(1, &1305 indmax(3)-indmin(3)+1, &1306 petab_child(3)-pttab_child(3)+1, &1307 s_parent(3),s_child(3),ds_parent(3),ds_child(3),1)1308 1309 do k=pttab_child(3),petab_child(3)1310 kref = k-pttab_child(3)+11311 kp=indmin(3)+indparentppm(kref,1)-11312 kp1 = kp + 11313 kp2 = kp1 + 11314 kp3 = kp2 + 11315 kp4 = kp3 + 11316 do j = pttab_child(2), petab_child(2)1317 do i = pttab_child(1), petab_child(1)1318 tabout(i,j,k) = tabppm(1,indchildppm(kref,1),1)*tabtemp(i,j,kp) + &1319 tabppm(2,indchildppm(kref,1),1)*tabtemp(i,j,kp1) + &1320 tabppm(3,indchildppm(kref,1),1)*tabtemp(i,j,kp2) + &1321 tabppm(4,indchildppm(kref,1),1)*tabtemp(i,j,kp3) + &1322 tabppm(5,indchildppm(kref,1),1)*tabtemp(i,j,kp4)1323 enddo1324 enddo1325 enddo1326 1327 1061 else 1328 1329 1062 do j = pttab_child(2), petab_child(2) 1330 1063 do i = pttab_child(1), petab_child(1) … … 1338 1071 enddo 1339 1072 enddo 1340 1341 1073 endif 1342 1074 !--------------------------------------------------------------------------------------------------- … … 1359 1091 integer, dimension(4), intent(in) :: indmin, indmax 1360 1092 integer, dimension(4), intent(in) :: pttab_child, petab_child 1361 real (kind=8), dimension(4), intent(in) :: s_child, s_parent1362 real (kind=8), dimension(4), intent(in) :: ds_child, ds_parent1093 real, dimension(4), intent(in) :: s_child, s_parent 1094 real, dimension(4), intent(in) :: ds_child, ds_parent 1363 1095 real, dimension( & 1364 1096 indmin(1):indmax(1), & … … 1378 1110 indmin(4):indmax(4)) :: tabtemp 1379 1111 integer :: i, j, k, l 1380 1381 real(kind=8) :: ypos,globind_parent_left1382 real(kind=8) :: deltax, invdsparent1383 real :: t2,t3,t4,t5,t6,t7,t81384 integer :: locind_parent_left, coeffraf1385 1112 ! 1386 1113 do l = indmin(4), indmax(4) … … 1398 1125 enddo 1399 1126 ! 1400 if (type_interp(4) == Agrif_LAGRANGE) then1401 coeffraf = nint(ds_parent(4)/ds_child(4))1402 invdsparent = 1./ds_parent(4)1403 ypos = s_child(4)1404 do l=pttab_child(4), petab_child(4)1405 locind_parent_left = indmin(4)+agrif_int((ypos - s_parent(4))/ds_parent(4))1406 globind_parent_left = s_parent(4) + (locind_parent_left - indmin(4))*ds_parent(4)1407 deltax = invdsparent*(ypos-globind_parent_left)1408 deltax = nint(coeffraf*deltax)/real(coeffraf)1409 ypos = ypos + ds_child(4)1410 1411 if (abs(deltax) <= 0.0001) then1412 do k = pttab_child(3), petab_child(3)1413 do j = pttab_child(2), petab_child(2)1414 do i = pttab_child(1), petab_child(1)1415 tabout(i,j,k,l) = tabtemp(i,j,k,locind_parent_left)1416 enddo1417 enddo1418 enddo1419 else1420 t2 = deltax - 2.1421 t3 = deltax - 1.1422 t4 = deltax + 1.1423 1424 t5 = -(1./6.)*deltax*t2*t31425 t6 = 0.5*t2*t3*t41426 t7 = -0.5*deltax*t2*t41427 t8 = (1./6.)*deltax*t3*t41428 do k = pttab_child(3), petab_child(3)1429 do j = pttab_child(2), petab_child(2)1430 do i = pttab_child(1), petab_child(1)1431 tabout(i,j,k,l) = t5*tabtemp(i,j,k,locind_parent_left-1) + t6*tabtemp(i,j,k,locind_parent_left) &1432 +t7*tabtemp(i,j,k,locind_parent_left+1) + t8*tabtemp(i,j,k,locind_parent_left+2)1433 enddo1434 enddo1435 enddo1436 endif1437 1438 enddo1439 else1440 1127 do k = pttab_child(3), petab_child(3) 1441 1128 do j = pttab_child(2), petab_child(2) … … 1451 1138 enddo 1452 1139 enddo 1453 endif1454 1140 !--------------------------------------------------------------------------------------------------- 1455 1141 end subroutine Agrif_Interp_4D_recursive … … 1471 1157 integer, dimension(5), intent(in) :: indmin, indmax 1472 1158 integer, dimension(5), intent(in) :: pttab_child, petab_child 1473 real (kind=8), dimension(5), intent(in) :: s_child, s_parent1474 real (kind=8), dimension(5), intent(in) :: ds_child, ds_parent1159 real, dimension(5), intent(in) :: s_child, s_parent 1160 real, dimension(5), intent(in) :: ds_child, ds_parent 1475 1161 real, dimension( & 1476 1162 indmin(1):indmax(1), & … … 1544 1230 integer, dimension(6), intent(in) :: indmin, indmax 1545 1231 integer, dimension(6), intent(in) :: pttab_child, petab_child 1546 real (kind=8), dimension(6), intent(in) :: s_child, s_parent1547 real (kind=8), dimension(6), intent(in) :: ds_child, ds_parent1232 real, dimension(6), intent(in) :: s_child, s_parent 1233 real, dimension(6), intent(in) :: ds_child, ds_parent 1548 1234 real, dimension( & 1549 1235 indmin(1):indmax(1), & … … 1623 1309 REAL, DIMENSION(indmin:indmax), INTENT(IN) :: parenttab 1624 1310 REAL, DIMENSION(pttab_child:petab_child), INTENT(OUT) :: childtab 1625 REAL (kind=8):: s_parent, s_child1626 REAL (kind=8):: ds_parent,ds_child1311 REAL :: s_parent, s_child 1312 REAL :: ds_parent,ds_child 1627 1313 ! 1628 1314 if ( (indmin == indmax) .and. (pttab_child == petab_child) ) then … … 1693 1379 !--------------------------------------------------------------------------------------------------- 1694 1380 function Agrif_Find_list_interp ( list_interp, pttab, petab, pttab_Child, pttab_Parent, & 1695 nbdim, indmin, indmax, indmin_required_p, indmax_required_p, & 1696 indminglob, indmaxglob, & 1381 nbdim, indmin, indmax, indminglob, indmaxglob, & 1697 1382 pttruetab, cetruetab, memberin & 1698 1383 #if defined AGRIF_MPI … … 1705 1390 integer, intent(in) :: nbdim 1706 1391 integer, dimension(nbdim), intent(in) :: pttab, petab, pttab_Child, pttab_Parent 1707 integer, dimension(nbdim), intent(out) :: indmin, indmax , indmin_required_p, indmax_required_p1392 integer, dimension(nbdim), intent(out) :: indmin, indmax 1708 1393 integer, dimension(nbdim), intent(out) :: indminglob, indmaxglob 1709 1394 integer, dimension(nbdim), intent(out) :: pttruetab, cetruetab … … 1744 1429 indmin = pil % indmin(1:nbdim) 1745 1430 indmax = pil % indmax(1:nbdim) 1746 indmin_required_p = pil % indmin_required_p(1:nbdim)1747 indmax_required_p = pil % indmax_required_p(1:nbdim)1748 1431 1749 1432 pttruetab = pil % pttruetab(1:nbdim) … … 1777 1460 !--------------------------------------------------------------------------------------------------- 1778 1461 subroutine Agrif_AddTo_list_interp ( list_interp, pttab, petab, pttab_Child, pttab_Parent, & 1779 indmin, indmax, indmin_required_p, indmax_required_p, & 1780 indminglob, indmaxglob, & 1462 indmin, indmax, indminglob, indmaxglob, & 1781 1463 pttruetab, cetruetab, & 1782 1464 memberin, nbdim & … … 1792 1474 integer :: nbdim 1793 1475 integer, dimension(nbdim) :: pttab, petab, pttab_Child, pttab_Parent 1794 integer, dimension(nbdim) :: indmin,indmax , indmin_required_p, indmax_required_p1476 integer, dimension(nbdim) :: indmin,indmax 1795 1477 integer, dimension(nbdim) :: indminglob, indmaxglob 1796 1478 integer, dimension(nbdim) :: pttruetab, cetruetab … … 1821 1503 pil % indmin(1:nbdim) = indmin(1:nbdim) 1822 1504 pil % indmax(1:nbdim) = indmax(1:nbdim) 1823 1824 pil % indmin_required_p(1:nbdim) = indmin_required_p(1:nbdim)1825 pil % indmax_required_p(1:nbdim) = indmax_required_p(1:nbdim)1826 1505 1827 1506 pil % memberin = memberin -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modinterpbasic.F90
r10087 r10725 41 41 integer, dimension(:), allocatable :: indparentppm_1d, indchildppm_1d 42 42 ! 43 44 43 private :: Agrif_limiter_vanleer 45 44 ! … … 57 56 integer, intent(in) :: np !< Length of input array 58 57 integer, intent(in) :: nc !< Length of output array 59 real (kind=8), intent(in) :: s_parent !< Parent grid position (s_root = 0)60 real (kind=8), intent(in) :: s_child !< Child grid position (s_root = 0)61 real (kind=8), intent(in) :: ds_parent !< Parent grid dx (ds_root = 1)62 real (kind=8), intent(in) :: ds_child !< Child grid dx (ds_root = 1)58 real, intent(in) :: s_parent !< Parent grid position (s_root = 0) 59 real, intent(in) :: s_child !< Child grid position (s_root = 0) 60 real, intent(in) :: ds_parent !< Parent grid dx (ds_root = 1) 61 real, intent(in) :: ds_child !< Child grid dx (ds_root = 1) 63 62 ! 64 63 integer :: i, coeffraf, locind_parent_left 65 real (kind=8):: globind_parent_left, globind_parent_right66 real (kind=8):: invds, invds2, ypos, ypos2, diff64 real :: globind_parent_left, globind_parent_right 65 real :: invds, invds2, ypos, ypos2, diff 67 66 ! 68 67 coeffraf = nint(ds_parent/ds_child) … … 93 92 ! 94 93 diff = globind_parent_right - ypos2 95 ! quick fix for roundoff error96 diff=nint(diff*coeffraf)/real(coeffraf)97 98 94 y(i) = (diff*x(locind_parent_left) + (1.-diff)*x(locind_parent_left+1)) 99 100 95 ypos2 = ypos2 + invds2 101 96 ! … … 109 104 else 110 105 globind_parent_left = s_parent + (locind_parent_left - 1)*ds_parent 111 diff=(globind_parent_left + ds_parent - ypos)*invds 112 113 ! quick fix for roundoff error 114 diff=nint(diff*coeffraf)/real(coeffraf) 115 ! y(nc) = ((globind_parent_left + ds_parent - ypos)*x(locind_parent_left) & 116 ! + (ypos - globind_parent_left)*x(locind_parent_left+1))*invds 117 y(nc) = (diff*x(locind_parent_left) + (1.-diff)*x(locind_parent_left+1)) 118 endif 119 106 y(nc) = ((globind_parent_left + ds_parent - ypos)*x(locind_parent_left) & 107 + (ypos - globind_parent_left)*x(locind_parent_left+1))*invds 108 endif 120 109 !--------------------------------------------------------------------------------------------------- 121 110 end subroutine Agrif_basicinterp_linear1D … … 131 120 !--------------------------------------------------------------------------------------------------- 132 121 integer, intent(in) :: np,nc,np2 133 real (kind=8), intent(in) :: s_parent, s_child134 real (kind=8), intent(in) :: ds_parent, ds_child122 real, intent(in) :: s_parent, s_child 123 real, intent(in) :: ds_parent, ds_child 135 124 integer, intent(in) :: dir 136 125 ! … … 138 127 integer, dimension(:,:), allocatable :: indparent_tmp 139 128 real, dimension(:,:), allocatable :: coeffparent_tmp 140 real (kind=8):: ypos,globind_parent_left,globind_parent_right141 real (kind=8):: invds, invds2, invds3142 real (kind=8):: ypos2,diff129 real :: ypos,globind_parent_left,globind_parent_right 130 real :: invds, invds2, invds3 131 real :: ypos2,diff 143 132 ! 144 133 coeffraf = nint(ds_parent/ds_child) … … 175 164 if (ypos2 > globind_parent_right) then 176 165 locind_parent_left = locind_parent_left + 1 177 globind_parent_right = globind_parent_right + 1. d0166 globind_parent_right = globind_parent_right + 1. 178 167 ypos2 = ypos*invds+(i-1)*invds2 179 168 endif … … 250 239 real, dimension(np), intent(in) :: x 251 240 real, dimension(nc), intent(out) :: y 252 real (kind=8), intent(in) :: s_parent, s_child253 real (kind=8), intent(in) :: ds_parent, ds_child241 real, intent(in) :: s_parent, s_child 242 real, intent(in) :: ds_parent, ds_child 254 243 ! 255 244 integer :: i, coeffraf, locind_parent_left 256 real (kind=8):: ypos,globind_parent_left257 real (kind=8):: deltax, invdsparent245 real :: ypos,globind_parent_left 246 real :: deltax, invdsparent 258 247 real :: t2,t3,t4,t5,t6,t7,t8 259 248 ! … … 315 304 real, dimension(np), intent(in) :: x 316 305 real, dimension(nc), intent(out) :: y 317 real (kind=8), intent(in) :: s_parent, s_child318 real (kind=8), intent(in) :: ds_parent, ds_child306 real, intent(in) :: s_parent, s_child 307 real, intent(in) :: ds_parent, ds_child 319 308 ! 320 309 integer :: i, coeffraf, locind_parent 321 real (kind=8):: ypos310 real :: ypos 322 311 ! 323 312 coeffraf = nint(ds_parent/ds_child) … … 353 342 real, dimension(np), intent(in) :: x 354 343 real, dimension(nc), intent(out) :: y 355 real (kind=8), intent(in) :: s_parent, s_child356 real (kind=8), intent(in) :: ds_parent, ds_child344 real, intent(in) :: s_parent, s_child 345 real, intent(in) :: ds_parent, ds_child 357 346 ! 358 347 real, dimension(:), allocatable :: ytemp 359 348 integer :: i,coeffraf,locind_parent_left,locind_parent_last 360 real (kind=8):: ypos,xdiffmod,xpmin,xpmax,slope349 real :: ypos,xdiffmod,xpmin,xpmax,slope 361 350 integer :: i1,i2,ii 362 351 integer :: diffmod … … 440 429 real, dimension(np), intent(in) :: x 441 430 real, dimension(nc), intent(out) :: y 442 real (kind=8), intent(in) :: s_parent, s_child443 real (kind=8), intent(in) :: ds_parent, ds_child431 real, intent(in) :: s_parent, s_child 432 real, intent(in) :: ds_parent, ds_child 444 433 ! 445 434 real, dimension(:), allocatable :: ytemp 446 435 integer :: i,coeffraf,locind_parent_left,locind_parent_last 447 real (kind=8):: ypos,xdiffmod,xpmin,xpmax,slope436 real :: ypos,xdiffmod,xpmin,xpmax,slope 448 437 integer :: i1,i2,ii 449 438 integer :: diffmod … … 535 524 real, dimension(np), intent(in) :: x 536 525 real, dimension(nc), intent(out) :: y 537 real (kind=8), intent(in) :: s_parent, s_child538 real (kind=8), intent(in) :: ds_parent, ds_child526 real, intent(in) :: s_parent, s_child 527 real, intent(in) :: ds_parent, ds_child 539 528 ! 540 529 integer :: i,coeffraf,locind_parent_left,locind_parent_last 541 530 integer :: iparent,ipos,pos,nmin,nmax 542 real (kind=8):: ypos531 real :: ypos 543 532 integer :: i1,jj 544 real(kind=8) :: xpmin 545 real :: a 533 real :: xpmin,a 546 534 ! 547 535 real, dimension(np) :: xl,delta,a6,slope … … 658 646 !--------------------------------------------------------------------------------------------------- 659 647 integer, intent(in) :: np2, np, nc 660 real (kind=8), intent(in) :: s_parent, s_child661 real (kind=8), intent(in) :: ds_parent, ds_child648 real, intent(in) :: s_parent, s_child 649 real, intent(in) :: ds_parent, ds_child 662 650 integer, intent(in) :: dir 663 651 ! … … 667 655 integer :: iparent,ipos,pos 668 656 real :: ypos 669 integer :: i1,jj,k,l,j 670 real(kind=8) :: xpmin 671 real :: a 657 integer :: i1,jj 658 real :: xpmin,a 672 659 ! 673 660 integer :: diffmod … … 751 738 enddo 752 739 ! 753 754 k=1 755 l=0 756 do i=1,np2 757 do j=1,nc 758 indchildppm(k,dir) = indchildppm_1d(j) 759 indparentppm(k,dir) = indparentppm_1d(j) + l 760 k=k+1 761 enddo 762 l=l+np 740 do i = 1,np2 741 indparentppm(1+(i-1)*nc:i*nc,dir) = indparentppm_1d(1:nc) + (i-1)*np 742 indchildppm (1+(i-1)*nc:i*nc,dir) = indchildppm_1d (1:nc) 763 743 enddo 764 744 !--------------------------------------------------------------------------------------------------- … … 766 746 !=================================================================================================== 767 747 ! 768 748 !=================================================================================================== 749 !subroutine PPM1dPrecompute(np,nc,& 750 ! s_parent,s_child,ds_parent,ds_child) 751 !! 752 !!CC Description: 753 !!CC subroutine to compute coefficient and index for a 1D interpolation 754 !!CC using piecewise parabolic method 755 !!C Method: 756 !! 757 !! Declarations: 758 !! 759 ! Implicit none 760 !! 761 !! Arguments 762 ! Integer :: np,nc 763 !! Real, Dimension(:),Allocatable :: ytemp 764 ! Real :: s_parent,s_child,ds_parent,ds_child 765 !! 766 !! Local scalars 767 ! Integer :: i,coeffraf,locind_parent_left,locind_parent_last 768 ! Integer :: iparent,ipos,pos,nmin,nmax 769 ! Real :: ypos 770 ! integer :: i1,jj 771 ! Real :: xpmin,a 772 !! 773 ! Real :: xrmin,xrmax,am3,s2,s1 774 ! Real, Dimension(np) :: xl,delta,a6,slope 775 !! Real, Dimension(:),Allocatable :: diff,diff2,diff3 776 ! INTEGER :: diffmod 777 ! REAL :: invcoeffraf 778 !! 779 ! coeffraf = nint(ds_parent/ds_child) 780 !! 781 ! If (coeffraf == 1) Then 782 ! return 783 ! End If 784 ! invcoeffraf = ds_child/ds_parent 785 !! 786 ! 787 ! if (.not.allocated(indparentppm)) then 788 ! allocate(indparentppm(-2*coeffraf:nc+2*coeffraf,1),& 789 ! indchildppm(-2*coeffraf:nc+2*coeffraf,1)) 790 ! else 791 ! if (size(indparentppm,1)<nc+4*coeffraf+1) then 792 ! deallocate(indparentppm,indchildppm) 793 ! allocate(indparentppm(-2*coeffraf:nc+2*coeffraf,1),& 794 ! indchildppm(-2*coeffraf:nc+2*coeffraf,1)) 795 ! endif 796 ! endif 797 ! 798 ! ypos = s_child 799 !! 800 ! locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent) 801 ! locind_parent_last = 1 +& 802 ! agrif_ceiling((ypos +(nc - 1)& 803 ! *ds_child - s_parent)/ds_parent) 804 !! 805 ! xpmin = s_parent + (locind_parent_left-1)*ds_parent 806 ! i1 = 1+agrif_int((xpmin-s_child)/ds_child) 807 !! 808 !! 809 ! 810 ! Do i=1,coeffraf 811 ! tabdiff2(i)=(real(i)-0.5)*invcoeffraf 812 ! EndDo 813 ! 814 ! a = invcoeffraf**2 815 ! tabdiff3(1) = (1./3.)*a 816 ! a=2.*a 817 !!CDIR ALTCODE 818 !!!!CDIR SHORTLOOP 819 ! Do i=2,coeffraf 820 ! tabdiff3(i) = tabdiff3(i-1)+(real(i)-1)*a 821 ! EndDo 822 ! 823 !!CDIR ALTCODE 824 !!!!CDIR SHORTLOOP 825 ! Do i=1,coeffraf 826 ! tabppm(1,i,1) = 0.08333333333333*(-1.+4*tabdiff2(i)-3*tabdiff3(i)) 827 ! tabppm(2,i,1) = 0.08333333333333*& 828 ! (7.-26.*tabdiff2(i)+18.*tabdiff3(i)) 829 ! tabppm(3,i,1) =0.08333333333333*(7.+30*tabdiff2(i)-30*tabdiff3(i)) 830 ! tabppm(4,i,1) = 0.08333333333333*& 831 ! (-1.-10.*tabdiff2(i)+18.*tabdiff3(i)) 832 ! tabppm(5,i,1) = 0.08333333333333*(2*tabdiff2(i)-3*tabdiff3(i)) 833 ! End Do 834 !! 835 !! 836 ! diffmod = 0 837 ! IF (mod(coeffraf,2) == 0) diffmod = 1 838 !! 839 ! ipos = i1 840 !! 841 ! Do iparent = locind_parent_left,locind_parent_last 842 ! pos=1 843 !!CDIR ALTCODE 844 !!CDIR SHORTLOOP 845 ! Do jj = ipos - coeffraf/2+diffmod,ipos + coeffraf/2 846 ! indparentppm(jj,1) = iparent-2 847 ! indchildppm(jj,1) = pos 848 ! pos = pos+1 849 ! End do 850 ! ipos = ipos + coeffraf 851 !! 852 ! End do 853 ! 854 ! Return 855 ! End subroutine ppm1dprecompute 769 856 !=================================================================================================== 770 857 ! … … 776 863 ! Use precomputed coefficient and index. 777 864 !--------------------------------------------------------------------------------------------------- 778 subroutine PPM1dAfterCompute ( x, y, np, nc, dir, indchildppmloc, tabppmloc ) 779 !--------------------------------------------------------------------------------------------------- 780 integer, intent(in) :: np, nc 865 subroutine PPM1dAfterCompute ( x, y, np, nc, dir ) 866 !--------------------------------------------------------------------------------------------------- 781 867 real, dimension(np), intent(in) :: x 782 868 real, dimension(nc), intent(out) :: y 869 integer, intent(in) :: np, nc 783 870 integer, intent(in) :: dir 784 integer, dimension(1:),intent(in) :: indchildppmloc 785 real, dimension(1:,1:),intent(in) :: tabppmloc 786 ! 787 integer :: i,j,jp1,jp2,jp3,jp4,k 788 789 871 ! 872 integer :: i 873 ! 790 874 do i = 1,nc 791 j = indparentppm(i,dir) 792 jp1=j+1 793 jp2=jp1+1 794 jp3=jp2+1 795 jp4=jp3+1 796 y(i) = tabppmloc(1,indchildppmloc(i)) * x(j) + & 797 tabppmloc(2,indchildppmloc(i)) * x(jp1) + & 798 tabppmloc(3,indchildppmloc(i)) * x(jp2) + & 799 tabppmloc(4,indchildppmloc(i)) * x(jp3) + & 800 tabppmloc(5,indchildppmloc(i)) * x(jp4) 801 enddo 802 875 y(i) = tabppm(1,indchildppm(i,dir),dir) * x(indparentppm(i,dir) ) + & 876 tabppm(2,indchildppm(i,dir),dir) * x(indparentppm(i,dir)+1) + & 877 tabppm(3,indchildppm(i,dir),dir) * x(indparentppm(i,dir)+2) + & 878 tabppm(4,indchildppm(i,dir),dir) * x(indparentppm(i,dir)+3) + & 879 tabppm(5,indchildppm(i,dir),dir) * x(indparentppm(i,dir)+4) 880 enddo 803 881 !--------------------------------------------------------------------------------------------------- 804 882 end subroutine PPM1dAfterCompute 805 806 883 !=================================================================================================== 807 884 ! … … 992 1069 real, dimension(np), intent(in) :: x 993 1070 real, dimension(nc), intent(out) :: y 994 real (kind=8), intent(in) :: s_parent, s_child995 real (kind=8), intent(in) :: ds_parent, ds_child1071 real, intent(in) :: s_parent, s_child 1072 real, intent(in) :: ds_parent, ds_child 996 1073 ! 997 1074 real, dimension(:), allocatable :: ytemp 998 1075 integer :: i,coeffraf,locind_parent_left,locind_parent_last 999 1076 integer :: iparent,ipos,pos,nmin,nmax 1000 real (kind=8):: ypos1077 real :: ypos 1001 1078 integer :: i1,jj 1002 real (kind=8):: xpmin1079 real :: xpmin 1003 1080 ! 1004 1081 real, dimension(np) :: slope … … 1089 1166 real, dimension(np), intent(in) :: x 1090 1167 real, dimension(nc), intent(out) :: y 1091 real (kind=8), intent(in) :: s_parent, s_child1092 real (kind=8), intent(in) :: ds_parent, ds_child1168 real, intent(in) :: s_parent, s_child 1169 real, intent(in) :: ds_parent, ds_child 1093 1170 ! 1094 1171 integer :: i,coeffraf,locind_parent_left,locind_parent_last 1095 1172 integer :: ipos, pos 1096 real (kind=8):: ypos,xi1173 real :: ypos,xi 1097 1174 integer :: i1,jj 1098 real (kind=8):: xpmin1175 real :: xpmin 1099 1176 ! 1100 1177 real, dimension(:), allocatable :: ytemp … … 1199 1276 Real, Dimension(nc) :: y 1200 1277 Real, Dimension(:),Allocatable :: ytemp 1201 Real (kind=8):: s_parent,s_child,ds_parent,ds_child1278 Real :: s_parent,s_child,ds_parent,ds_child 1202 1279 ! 1203 1280 ! Local scalars 1204 1281 Integer :: i,coeffraf,locind_parent_left,locind_parent_last 1205 1282 Integer :: iparent,ipos,pos,nmin,nmax 1206 Real (kind=8):: ypos1283 Real :: ypos 1207 1284 integer :: i1,jj 1208 Real(kind=8) :: xpmin 1209 real :: cavg,a,b 1285 Real :: xpmin,cavg,a,b 1210 1286 ! 1211 1287 Real :: xrmin,xrmax,am3,s2,s1 -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modmask.F90
r10087 r10725 40 40 !! when this one is equal to Agrif_SpecialValue. 41 41 !--------------------------------------------------------------------------------------------------- 42 subroutine Agrif_CheckMasknD ( tempP, parent, pbtab, petab, ppbtab, ppetab, & 43 pbtab_required, petab_required, noraftab, nbdim ) 42 subroutine Agrif_CheckMasknD ( tempP, parent, pbtab, petab, ppbtab, ppetab, noraftab, nbdim ) 44 43 !--------------------------------------------------------------------------------------------------- 45 44 type(Agrif_Variable), pointer :: tempP !< Part of the parent grid used for the interpolation of the child grid … … 47 46 integer, dimension(nbdim) :: pbtab !< limits of the parent grid used 48 47 integer, dimension(nbdim) :: petab !< interpolation of the child grid 49 integer, dimension(nbdim) :: ppbtab, ppetab , pbtab_required, petab_required48 integer, dimension(nbdim) :: ppbtab, ppetab 50 49 logical, dimension(nbdim) :: noraftab 51 50 integer :: nbdim 52 51 ! 53 integer :: i0,j0,k0,l0,m0,n0,ll,kk 54 integer,dimension(:,:),allocatable :: trytoreplace 55 integer :: ilook, Nbvals 56 real :: xold 52 integer :: i0,j0,k0,l0,m0,n0 57 53 ! 58 54 select case (nbdim) … … 81 77 parent%array3(ppbtab(1),ppbtab(2),ppbtab(3)), & 82 78 ppbtab,ppetab,noraftab,MaxSearch,Agrif_SpecialValue) 79 80 ! Call CalculNewValTempP((/i0,j0,k0/), 81 ! & tempP,parent, 82 ! & ppbtab,ppetab, 83 ! & noraftab,nbdim) 84 83 85 endif 84 86 enddo … … 86 88 enddo 87 89 case (4) 88 89 if (noraftab(1).AND.noraftab(2)) then 90 allocate(trytoreplace(pbtab_required(3):petab_required(3),pbtab_required(4):petab_required(4))) 91 trytoreplace = -1 92 i0 = pbtab_required(1) 93 j0 = pbtab_required(2) 94 do l0 = pbtab_required(4),petab_required(4) 95 do k0 = pbtab_required(3),petab_required(3) 90 do l0 = pbtab(4),petab(4) 91 do k0 = pbtab(3),petab(3) 92 do j0 = pbtab(2),petab(2) 93 do i0 = pbtab(1),petab(1) 96 94 if (tempP%array4(i0,j0,k0,l0) == Agrif_SpecialValue) then 97 95 call CalculNewValTempP4D((/i0,j0,k0,l0/), & 98 96 tempP%array4(ppbtab(1),ppbtab(2),ppbtab(3),ppbtab(4)), & 99 97 parent%array4(ppbtab(1),ppbtab(2),ppbtab(3),ppbtab(4)), & 100 ppbtab,ppetab,noraftab,MaxSearch,Agrif_SpecialValue, & 101 trytoreplace(k0,l0)) 102 endif 103 enddo 104 enddo 105 106 do l0 = pbtab_required(4),petab_required(4) 107 do k0 = pbtab_required(3),petab_required(3) 108 if (trytoreplace(k0,l0) /= -1) then 109 do j0 = pbtab_required(2),petab_required(2) 110 do i0 = pbtab_required(1),petab_required(1) 111 112 if (tempP%array4(i0,j0,k0,l0) == Agrif_SpecialValue) then 113 tempP%array4(i0,j0,k0,l0) = 0. 114 Nbvals = 0 115 do ll=max(l0-trytoreplace(k0,l0),ppbtab(4)),min(l0+trytoreplace(k0,l0),ppetab(4)) 116 do kk=max(k0-trytoreplace(k0,l0),ppbtab(3)),min(k0+trytoreplace(k0,l0),ppetab(3)) 117 if (parent%array4(i0,j0,kk,ll) /= Agrif_SpecialValue) then 118 tempP%array4(i0,j0,k0,l0) = tempP%array4(i0,j0,k0,l0) + parent%array4(i0,j0,kk,ll) 119 Nbvals = Nbvals + 1 120 endif 121 enddo 122 enddo 123 124 tempP%array4(i0,j0,k0,l0) = tempP%array4(i0,j0,k0,l0) /Nbvals 125 endif 126 enddo 127 enddo 128 endif 129 enddo 130 enddo 131 deallocate(trytoreplace) 132 133 else 134 135 do l0 = pbtab_required(4),petab_required(4) 136 do k0 = pbtab_required(3),petab_required(3) 137 do j0 = pbtab_required(2),petab_required(2) 138 do i0 = pbtab_required(1),petab_required(1) 139 if (tempP%array4(i0,j0,k0,l0) == Agrif_SpecialValue) then 140 ilook = -1 141 call CalculNewValTempP4D((/i0,j0,k0,l0/), & 142 tempP%array4(ppbtab(1),ppbtab(2),ppbtab(3),ppbtab(4)), & 143 parent%array4(ppbtab(1),ppbtab(2),ppbtab(3),ppbtab(4)), & 144 ppbtab,ppetab,noraftab,MaxSearch,Agrif_SpecialValue,ilook) 145 endif 146 enddo 147 enddo 148 enddo 149 enddo 150 151 endif 98 ppbtab,ppetab,noraftab,MaxSearch,Agrif_SpecialValue) 99 endif 100 enddo 101 enddo 102 enddo 103 enddo 152 104 case (5) 153 105 do m0 = pbtab(5),petab(5) … … 536 488 !--------------------------------------------------------------------------------------------------- 537 489 subroutine CalculNewValTempP4D ( indic, tempP, parent, ppbtab, ppetab, noraftab, & 538 MaxSearch, Agrif_SpecialValue , ilook)490 MaxSearch, Agrif_SpecialValue ) 539 491 !--------------------------------------------------------------------------------------------------- 540 492 integer, parameter :: nbdim = 4 … … 559 511 ! 560 512 logical :: firsttest 561 integer :: ilook562 513 ! 563 514 ValMax = 1 … … 577 528 firsttest = .TRUE. 578 529 idecal = indic 579 580 if (ilook /= -1) then581 i = ilook582 else583 i = 1584 endif585 530 ! 586 531 do while (i <= ValMax) 587 532 ! 588 !if ((i == 1).AND.(firsttest)) i = Valmax533 if ((i == 1).AND.(firsttest)) i = Valmax 589 534 590 535 do iii = 1,nbdim … … 592 537 imin(iii) = max(indic(iii) - i,ppbtab(iii)) 593 538 imax(iii) = min(indic(iii) + i,ppetab(iii)) 594 !if (firsttest) then595 !if (indic(iii) > ppbtab(iii)) then596 !idecal(iii) = idecal(iii)-1597 !if (tempP(idecal(1),idecal(2),idecal(3),idecal(4)) == Agrif_SpecialValue) then598 !imin(iii) = imax(iii)599 !endif600 !idecal(iii) = idecal(iii)+1601 !endif602 !endif539 if (firsttest) then 540 if (indic(iii) > ppbtab(iii)) then 541 idecal(iii) = idecal(iii)-1 542 if (tempP(idecal(1),idecal(2),idecal(3),idecal(4)) == Agrif_SpecialValue) then 543 imin(iii) = imax(iii) 544 endif 545 idecal(iii) = idecal(iii)+1 546 endif 547 endif 603 548 endif 604 549 enddo … … 622 567 ! 623 568 if (Nbvals > 0) then 624 !if (firsttest) then625 !firsttest = .FALSE.626 !i=1627 !cycle628 !endif569 if (firsttest) then 570 firsttest = .FALSE. 571 i=1 572 cycle 573 endif 629 574 630 575 tempP(indic(1),indic(2),indic(3),indic(4)) = Res/Nbvals 631 ilook = i632 576 exit 633 577 else 634 !if (firsttest) exit578 if (firsttest) exit 635 579 i = i + 1 636 580 endif -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modsauv.F90
r10087 r10725 27 27 ! 28 28 module Agrif_Save 29 ! 29 ! 30 30 use Agrif_Types 31 31 use Agrif_Link 32 32 use Agrif_Arrays 33 use Agrif_ User_Variables33 use Agrif_Variables 34 34 ! 35 35 implicit none … … 250 250 ! 251 251 type(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive procedure 252 real (kind=8):: g_eps, eps, oldgrid_eps252 real :: g_eps, eps, oldgrid_eps 253 253 integer :: out 254 254 integer :: iii … … 331 331 ! 332 332 type(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive procedure 333 real (kind=8):: g_eps,eps,oldgrid_eps333 real :: g_eps,eps,oldgrid_eps 334 334 integer :: out 335 335 integer :: iii … … 415 415 integer, dimension(6) :: nbtabold ! Number of cells in each direction 416 416 integer, dimension(6) :: nbtabnew ! Number of cells in each direction 417 real (kind=8), dimension(6) :: snew,sold418 real (kind=8), dimension(6) :: dsnew,dsold419 real (kind=8):: eps417 real, dimension(6) :: snew,sold 418 real, dimension(6) :: dsnew,dsold 419 real :: eps 420 420 integer :: n 421 421 ! … … 531 531 integer, dimension(nbdim), intent(in) :: pttabold 532 532 integer, dimension(nbdim), intent(in) :: petabold 533 real (kind=8), dimension(nbdim), intent(in) :: snew, sold534 real (kind=8), dimension(nbdim), intent(in) :: dsnew,dsold533 real, dimension(nbdim), intent(in) :: snew, sold 534 real, dimension(nbdim), intent(in) :: dsnew,dsold 535 535 integer, intent(in) :: nbdim 536 536 ! 537 537 integer :: i,j,k,l,m,n,i0,j0,k0,l0,m0,n0 538 538 ! 539 real (kind=8), dimension(nbdim) :: dim_gmin, dim_gmax540 real (kind=8), dimension(nbdim) :: dim_newmin, dim_newmax541 real (kind=8), dimension(nbdim) :: dim_min539 real, dimension(nbdim) :: dim_gmin, dim_gmax 540 real, dimension(nbdim) :: dim_newmin, dim_newmax 541 real, dimension(nbdim) :: dim_min 542 542 integer, dimension(nbdim) :: ind_gmin,ind_newmin, ind_newmax 543 543 ! -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modseq.F90
r10087 r10725 3 3 use Agrif_Init 4 4 use Agrif_Procs 5 use Agrif_Grids 6 !use Agrif_Arrays 5 use Agrif_Arrays 7 6 ! 8 7 implicit none -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modtypes.F90
r10098 r10725 111 111 !> \name Arrays containing the values of the grid variables (real) 112 112 !> @{ 113 real, dimension(:) , pointer :: parray1 => NULL()114 real, dimension(:,:) , pointer :: parray2 => NULL()115 real, dimension(:,:,:) , pointer :: parray3 => NULL()116 real, dimension(:,:,:,:) , pointer :: parray4 => NULL()117 real, dimension(:,:,:,:,:) , pointer :: parray5 => NULL()118 real, dimension(:,:,:,:,:,:), pointer :: parray6 => NULL()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 119 !> @} 120 120 !> \name Arrays containing the values of the grid variables (real*8) 121 121 !> @{ 122 real(8), dimension(:) , pointer :: pdarray1 => NULL()123 real(8), dimension(:,:) , pointer :: pdarray2 => NULL()124 real(8), dimension(:,:,:) , pointer :: pdarray3 => NULL()125 real(8), dimension(:,:,:,:) , pointer :: pdarray4 => NULL()126 real(8), dimension(:,:,:,:,:) , pointer :: pdarray5 => NULL()127 real(8), dimension(:,:,:,:,:,:), pointer :: pdarray6 => NULL()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 128 !> @} 129 129 !> \name Arrays containing the values of the grid variables (real*4) 130 130 !> @{ 131 real(4), dimension(:) , pointer :: psarray1 => NULL()132 real(4), dimension(:,:) , pointer :: psarray2 => NULL()133 real(4), dimension(:,:,:) , pointer :: psarray3 => NULL()134 real(4), dimension(:,:,:,:) , pointer :: psarray4 => NULL()135 real(4), dimension(:,:,:,:,:) , pointer :: psarray5 => NULL()136 real(4), dimension(:,:,:,:,:,:), pointer :: psarray6 => NULL()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 137 !> @} 138 138 !> \name Arrays used to restore the values … … 159 159 integer, dimension(6) :: ub 160 160 161 integer, dimension(6,2) :: lubglob162 163 161 logical,dimension(6,2) :: memberin 164 162 integer,dimension(6,2,2,6,2) :: childarray … … 288 286 integer,dimension(6) :: pttab, petab, pttab_Child, pttab_Parent = -99 289 287 integer,dimension(6) :: indmin, indmax 290 integer,dimension(6) :: indmin_required_p, indmax_required_p291 288 integer,dimension(6) :: pttruetab,cetruetab 292 289 logical :: member, memberin … … 354 351 real :: Agrif_Efficiency = 0.7 355 352 integer :: MaxSearch = 5 356 real (kind=8), dimension(3) :: Agrif_mind353 real, dimension(3) :: Agrif_mind 357 354 !> @} 358 355 !> \name parameters for the interpolation of the child grids … … 374 371 integer, parameter :: Agrif_Update_Average = 2 !< average 375 372 integer, parameter :: Agrif_Update_Full_Weighting = 3 !< full-weighting 373 integer, parameter :: Agrif_Update_Max = 4 !< Max 376 374 !> @} 377 375 !> \name Raffinement grid switches … … 418 416 integer function Agrif_Ceiling ( x ) 419 417 !--------------------------------------------------------------------------------------------------- 420 real (kind=8),intent(in) :: x418 real, intent(in) :: x 421 419 ! 422 420 integer :: i … … 438 436 integer function Agrif_Int(x) 439 437 !--------------------------------------------------------------------------------------------------- 440 real (kind=8),intent(in) :: x438 real, intent(in) :: x 441 439 ! 442 440 integer :: i -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modupdate.F90
r10087 r10725 27 27 module Agrif_Update 28 28 ! 29 ! use Agrif_UpdateBasic30 ! use Agrif_Arrays31 ! use Agrif_CurgridFunctions32 ! use Agrif_Mask33 #if defined AGRIF_MPI34 ! use Agrif_Mpp35 #endif36 !37 29 use Agrif_UpdateBasic 38 30 use Agrif_Arrays 39 use Agrif_User_Functions 40 use Agrif_Init 31 use Agrif_CurgridFunctions 41 32 use Agrif_Mask 42 43 33 #if defined AGRIF_MPI 44 34 use Agrif_Mpp … … 68 58 integer, dimension(6) :: ub_child 69 59 integer, dimension(6) :: lb_parent 70 real (kind=8), dimension(6) :: s_child ! Child grid position (s_root = 0)71 real (kind=8), dimension(6) :: s_parent ! Parent grid position (s_root = 0)72 real (kind=8), dimension(6) :: ds_child ! Child grid dx (ds_root = 1)73 real (kind=8), dimension(6) :: ds_parent ! Parent grid dx (ds_root = 1)60 real , dimension(6) :: s_child ! Child grid position (s_root = 0) 61 real , dimension(6) :: s_parent ! Parent grid position (s_root = 0) 62 real , dimension(6) :: ds_child ! Child grid dx (ds_root = 1) 63 real , dimension(6) :: ds_parent ! Parent grid dx (ds_root = 1) 74 64 logical, dimension(6) :: do_update ! Indicates if we perform update for each dimension 75 65 integer, dimension(6) :: posvar ! Position of the variable on the cell (1 or 2) … … 170 160 integer, dimension(nbdim), intent(in) :: posvar !< Position of the variable on the cell (1 or 2) 171 161 logical, dimension(nbdim), intent(in) :: do_update !< Indicates if we update for each dimension 172 real (kind=8), dimension(nbdim), intent(in) :: s_child !< Positions of the child grid173 real (kind=8), dimension(nbdim), intent(in) :: s_parent !< Positions of the parent grid174 real (kind=8), dimension(nbdim), intent(in) :: ds_child !< Space steps of the child grid175 real (kind=8), dimension(nbdim), intent(in) :: ds_parent !< Space steps of the parent grid162 real, dimension(nbdim), intent(in) :: s_child !< Positions of the child grid 163 real, dimension(nbdim), intent(in) :: s_parent !< Positions of the parent grid 164 real, dimension(nbdim), intent(in) :: ds_child !< Space steps of the child grid 165 real, dimension(nbdim), intent(in) :: ds_parent !< Space steps of the parent grid 176 166 procedure() :: procname !< Data recovery procedure 177 167 ! … … 240 230 ! lubglob(:,2) : global lbound for each dimension 241 231 ! 242 ! call Agrif_get_var_global_bounds(child, lubglob, nbdim) 243 lubglob = child % lubglob(1:nbdim,:) 232 call Agrif_get_var_global_bounds(child, lubglob, nbdim) 244 233 ! 245 234 indtruetab(1:nbdim,1,1) = max(indtab(1:nbdim,1,1), lubglob(1:nbdim,1)) … … 285 274 integer, dimension(nbdim), intent(in) :: posvar !< Position of the variable on the cell (1 or 2) 286 275 logical, dimension(nbdim), intent(in) :: do_update !< Indicates if we update for each dimension 287 real (kind=8), dimension(nbdim), intent(in) :: s_child !< Positions of the child grid288 real (kind=8), dimension(nbdim), intent(in) :: s_parent !< Positions of the parent grid289 real (kind=8), dimension(nbdim), intent(in) :: ds_child !< Space steps of the child grid290 real (kind=8), dimension(nbdim), intent(in) :: ds_parent !< Space steps of the parent grid276 real, dimension(nbdim), intent(in) :: s_child !< Positions of the child grid 277 real, dimension(nbdim), intent(in) :: s_parent !< Positions of the parent grid 278 real, dimension(nbdim), intent(in) :: ds_child !< Space steps of the child grid 279 real, dimension(nbdim), intent(in) :: ds_parent !< Space steps of the parent grid 291 280 procedure() :: procname !< Data recovery procedure 292 281 ! … … 411 400 integer, dimension(nbdim), intent(in) :: lb_parent !< Index of the first point inside the domain for the parent 412 401 !! grid variable 413 real (kind=8), dimension(nbdim), intent(in) :: s_child !< Positions of the child grid414 real (kind=8), dimension(nbdim), intent(in) :: s_parent !< Positions of the parent grid415 real (kind=8), dimension(nbdim), intent(in) :: ds_child !< Space steps of the child grid416 real (kind=8), dimension(nbdim), intent(in) :: ds_parent !< Space steps of the parent grid402 real, dimension(nbdim), intent(in) :: s_child !< Positions of the child grid 403 real, dimension(nbdim), intent(in) :: s_parent !< Positions of the parent grid 404 real, dimension(nbdim), intent(in) :: ds_child !< Space steps of the child grid 405 real, dimension(nbdim), intent(in) :: ds_parent !< Space steps of the parent grid 417 406 procedure() :: procname !< Data recovery procedure 418 407 integer, optional, intent(in) :: nb, ndir … … 426 415 integer, dimension(nbdim) :: indmin, indmax 427 416 integer, dimension(nbdim) :: indminglob, indmaxglob 428 real (kind=8), dimension(nbdim) :: s_Child_temp, s_Parent_temp417 real , dimension(nbdim) :: s_Child_temp, s_Parent_temp 429 418 integer, dimension(nbdim) :: lowerbound,upperbound 430 419 integer, dimension(nbdim) :: pttruetabwhole, cetruetabwhole … … 461 450 real :: coeff_multi 462 451 integer :: nb_dimensions 463 464 452 ! 465 453 ! Get local lower and upper bound of the child variable … … 518 506 ! 519 507 call Agrif_array_allocate(tempC,pttruetab,cetruetab,nbdim) 520 #if defined AGRIF_MPI521 508 call Agrif_var_set_array_tozero(tempC,nbdim) 522 #endif523 509 524 510 SELECT CASE (nbdim) … … 615 601 ! 616 602 call Agrif_array_allocate(tempP,indmin,indmax,nbdim) 617 618 IF (Agrif_UseSpecialValueInUpdate) THEN 619 allocate(tempC_indic) 620 allocate(tempP_indic) 621 call Agrif_array_allocate(tempC_indic,pttruetabwhole,cetruetabwhole,nbdim) 622 call Agrif_array_allocate(tempP_indic,indmin,indmax,nbdim) 623 call agrif_set_array_cond(tempCextend,tempC_indic,agrif_SpecialValueFineGrid,nbdim) 624 ELSE 625 tempC_indic=>tempCextend ! Just to associate tempC_indic to something ... 626 ENDIF 627 ! 628 629 603 ! 630 604 if ( nbdim == 1 ) then 631 605 tempP % array1 = 0. … … 633 607 tempP%array1, & 634 608 tempCextend%array1, & 635 tempC_indic%array1, &636 609 indmin(1), indmax(1), & 637 610 pttruetabwhole(1), cetruetabwhole(1), & … … 640 613 641 614 IF (Agrif_UseSpecialValueInUpdate) THEN 615 allocate(tempC_indic) 616 allocate(tempP_indic) 617 call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array1),ubound(tempCextend%array1),nbdim) 618 call Agrif_array_allocate(tempP_indic,lbound(tempP%array1),ubound(tempP%array1),nbdim) 642 619 643 620 compute_average = .FALSE. … … 653 630 tempP_average%array1, & 654 631 tempCextend%array1, & 655 tempC_indic%array1, &656 632 indmin(1), indmax(1), & 657 633 pttruetabwhole(1), cetruetabwhole(1), & … … 664 640 ENDIF 665 641 642 WHERE (tempCextend%array1 == Agrif_SpecialValueFineGrid) 643 tempC_indic%array1 = 0. 644 ELSEWHERE 645 tempC_indic%array1 = 1. 646 END WHERE 647 666 648 Agrif_UseSpecialValueInUpdate = .FALSE. 667 649 Agrif_Update_Weights = .TRUE. … … 669 651 call Agrif_Update_1D_Recursive( type_update_temp(1), & 670 652 tempP_indic%array1, & 671 tempC_indic%array1, &672 653 tempC_indic%array1, & 673 654 indmin(1), indmax(1), & … … 711 692 tempP%array2, & 712 693 tempCextend%array2, & 713 tempC_indic%array2, &714 694 indmin(1:2), indmax(1:2), & 715 695 pttruetabwhole(1:2), cetruetabwhole(1:2), & … … 718 698 719 699 IF (Agrif_UseSpecialValueInUpdate) THEN 700 allocate(tempC_indic) 701 allocate(tempP_indic) 702 call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array2),ubound(tempCextend%array2),nbdim) 703 call Agrif_array_allocate(tempP_indic,lbound(tempP%array2),ubound(tempP%array2),nbdim) 720 704 721 705 compute_average = .FALSE. … … 731 715 tempP_average%array2, & 732 716 tempCextend%array2, & 733 tempC_indic%array2, &734 717 indmin(1:2), indmax(1:2), & 735 718 pttruetabwhole(1:2), cetruetabwhole(1:2), & … … 742 725 ENDIF 743 726 727 WHERE (tempCextend%array2 == Agrif_SpecialValueFineGrid) 728 tempC_indic%array2 = 0. 729 ELSEWHERE 730 tempC_indic%array2 = 1. 731 END WHERE 732 744 733 Agrif_UseSpecialValueInUpdate = .FALSE. 745 734 Agrif_Update_Weights = .TRUE. … … 747 736 call Agrif_Update_2D_Recursive( type_update_temp(1:2), & 748 737 tempP_indic%array2, & 749 tempC_indic%array2, &750 738 tempC_indic%array2, & 751 739 indmin(1:2), indmax(1:2), & … … 786 774 endif 787 775 if ( nbdim == 3 ) then 788 789 776 call Agrif_Update_3D_Recursive( type_update(1:3), & 790 777 tempP%array3, & 791 778 tempCextend%array3, & 792 tempC_indic%array3, &793 779 indmin(1:3), indmax(1:3), & 794 780 pttruetabwhole(1:3), cetruetabwhole(1:3), & 795 781 s_Child_temp(1:3), s_Parent_temp(1:3), & 796 782 ds_child(1:3), ds_parent(1:3) ) 797 798 783 799 784 IF (Agrif_UseSpecialValueInUpdate) THEN 785 allocate(tempC_indic) 786 allocate(tempP_indic) 787 call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array3),ubound(tempCextend%array3),nbdim) 788 call Agrif_array_allocate(tempP_indic,lbound(tempP%array3),ubound(tempP%array3),nbdim) 800 789 801 790 compute_average = .FALSE. … … 808 797 type_update_temp(1:nbdim) = Agrif_Update_Average 809 798 END WHERE 810 811 799 call Agrif_Update_3D_Recursive( type_update_temp(1:3), & 812 800 tempP_average%array3, & 813 801 tempCextend%array3, & 814 tempC_indic%array3, &815 802 indmin(1:3), indmax(1:3), & 816 803 pttruetabwhole(1:3), cetruetabwhole(1:3), & … … 822 809 enddo 823 810 ENDIF 824 811 812 WHERE (tempCextend%array3 == Agrif_SpecialValueFineGrid) 813 tempC_indic%array3 = 0. 814 ELSEWHERE 815 tempC_indic%array3 = 1. 816 END WHERE 817 825 818 Agrif_UseSpecialValueInUpdate = .FALSE. 826 819 Agrif_Update_Weights = .TRUE. 827 828 820 829 821 call Agrif_Update_3D_Recursive( type_update_temp(1:3), & 830 822 tempP_indic%array3, & 831 823 tempC_indic%array3, & 832 tempCextend%array3, &833 824 indmin(1:3), indmax(1:3), & 834 825 pttruetabwhole(1:3), cetruetabwhole(1:3), & … … 836 827 ds_child(1:3), ds_parent(1:3) ) 837 828 838 839 829 Agrif_UseSpecialValueInUpdate = .TRUE. 840 830 Agrif_Update_Weights = .FALSE. 841 831 842 843 832 IF (compute_average) THEN 844 845 833 WHERE (tempP_indic%array3 == 0.) 846 834 tempP%array3 = Agrif_SpecialValueFineGrid … … 850 838 tempP%array3 = tempP_average%array3 /tempP_indic%array3 851 839 END WHERE 852 840 853 841 ELSE 854 842 WHERE (tempP_indic%array3 == 0.) … … 858 846 END WHERE 859 847 ENDIF 860 848 861 849 deallocate(tempP_indic%array3) 862 850 deallocate(tempC_indic%array3) … … 868 856 ENDIF 869 857 ENDIF 870 871 858 872 859 endif 873 860 if ( nbdim == 4 ) then 874 875 861 call Agrif_Update_4D_Recursive( type_update(1:4), & 876 862 tempP%array4, & 877 863 tempCextend%array4, & 878 tempC_indic%array4, &879 864 indmin(1:4), indmax(1:4), & 880 865 pttruetabwhole(1:4), cetruetabwhole(1:4), & 881 866 s_Child_temp(1:4), s_Parent_temp(1:4), & 882 867 ds_child(1:4), ds_parent(1:4) ) 883 868 884 869 IF (Agrif_UseSpecialValueInUpdate) THEN 870 871 allocate(tempC_indic) 872 allocate(tempP_indic) 873 call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array4),ubound(tempCextend%array4),nbdim) 874 call Agrif_array_allocate(tempP_indic,lbound(tempP%array4),ubound(tempP%array4),nbdim) 885 875 886 876 compute_average = .FALSE. … … 896 886 tempP_average%array4, & 897 887 tempCextend%array4, & 898 tempC_indic%array4, &899 888 indmin(1:4), indmax(1:4), & 900 889 pttruetabwhole(1:4), cetruetabwhole(1:4), & … … 907 896 ENDIF 908 897 898 WHERE (tempCextend%array4 == Agrif_SpecialValueFineGrid) 899 tempC_indic%array4 = 0. 900 ELSEWHERE 901 tempC_indic%array4 = 1. 902 END WHERE 903 909 904 Agrif_UseSpecialValueInUpdate = .FALSE. 910 905 Agrif_Update_Weights = .TRUE. … … 912 907 call Agrif_Update_4D_Recursive( type_update_temp(1:4), & 913 908 tempP_indic%array4, & 914 tempC_indic%array4, &915 909 tempC_indic%array4, & 916 910 indmin(1:4), indmax(1:4), & … … 947 941 ENDIF 948 942 ENDIF 949 943 950 944 endif 951 945 if ( nbdim == 5 ) then … … 953 947 tempP%array5, & 954 948 tempCextend%array5, & 955 tempC_indic%array5, &956 949 indmin(1:5), indmax(1:5), & 957 950 pttruetabwhole(1:5), cetruetabwhole(1:5), & … … 960 953 961 954 IF (Agrif_UseSpecialValueInUpdate) THEN 955 allocate(tempC_indic) 956 allocate(tempP_indic) 957 call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array5),ubound(tempCextend%array5),nbdim) 958 call Agrif_array_allocate(tempP_indic,lbound(tempP%array5),ubound(tempP%array5),nbdim) 962 959 963 960 compute_average = .FALSE. … … 973 970 tempP_average%array5, & 974 971 tempCextend%array5, & 975 tempC_indic%array5, &976 972 indmin(1:5), indmax(1:5), & 977 973 pttruetabwhole(1:5), cetruetabwhole(1:5), & … … 984 980 ENDIF 985 981 982 WHERE (tempCextend%array5 == Agrif_SpecialValueFineGrid) 983 tempC_indic%array5 = 0. 984 ELSEWHERE 985 tempC_indic%array5 = 1. 986 END WHERE 987 986 988 Agrif_UseSpecialValueInUpdate = .FALSE. 987 989 Agrif_Update_Weights = .TRUE. … … 989 991 call Agrif_Update_5D_Recursive( type_update_temp(1:5), & 990 992 tempP_indic%array5, & 991 tempC_indic%array5, &992 993 tempC_indic%array5, & 993 994 indmin(1:5), indmax(1:5), & … … 1031 1032 tempP%array6, & 1032 1033 tempCextend%array6, & 1033 tempC_indic%array6, &1034 1034 indmin(1:6), indmax(1:6), & 1035 1035 pttruetabwhole(1:6), cetruetabwhole(1:6), & 1036 1036 s_Child_temp(1:6), s_Parent_temp(1:6), & 1037 1037 ds_child(1:6), ds_parent(1:6) ) 1038 1039 1038 IF (Agrif_UseSpecialValueInUpdate) THEN 1039 allocate(tempC_indic) 1040 allocate(tempP_indic) 1041 call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array6),ubound(tempCextend%array6),nbdim) 1042 call Agrif_array_allocate(tempP_indic,lbound(tempP%array6),ubound(tempP%array6),nbdim) 1040 1043 1041 1044 compute_average = .FALSE. … … 1052 1055 tempP_average%array6, & 1053 1056 tempCextend%array6, & 1054 tempC_indic%array6, &1055 1057 indmin(1:6), indmax(1:6), & 1056 1058 pttruetabwhole(1:6), cetruetabwhole(1:6), & … … 1063 1065 ENDIF 1064 1066 1065 1066 Agrif_UseSpecialValueInUpdate = .FALSE.1067 Agrif_Update_Weights = .TRUE.1068 1069 call Agrif_Update_6D_Recursive( type_update_temp(1:6), &1070 tempP_indic%array6, &1071 tempC_indic%array6, &1072 tempC_indic%array6, &1073 indmin(1:6), indmax(1:6), &1074 pttruetabwhole(1:6), cetruetabwhole(1:6), &1075 s_Child_temp(1:6), s_Parent_temp(1:6), &1076 ds_child(1:6), ds_parent(1:6) )1077 1078 Agrif_UseSpecialValueInUpdate = .TRUE.1079 Agrif_Update_Weights = .FALSE.1080 1081 1067 IF (compute_average) THEN 1082 1068 WHERE (tempP_indic%array6 == 0.) … … 1095 1081 END WHERE 1096 1082 ENDIF 1083 1084 Agrif_UseSpecialValueInUpdate = .FALSE. 1085 Agrif_Update_Weights = .TRUE. 1086 1087 call Agrif_Update_6D_Recursive( type_update_temp(1:6), & 1088 tempP_indic%array6, & 1089 tempC_indic%array6, & 1090 indmin(1:6), indmax(1:6), & 1091 pttruetabwhole(1:6), cetruetabwhole(1:6), & 1092 s_Child_temp(1:6), s_Parent_temp(1:6), & 1093 ds_child(1:6), ds_parent(1:6) ) 1094 1095 Agrif_UseSpecialValueInUpdate = .TRUE. 1096 Agrif_Update_Weights = .FALSE. 1097 1098 WHERE (tempP_indic%array6 == 0.) 1099 tempP%array6 = Agrif_SpecialValueFineGrid 1100 ELSEWHERE 1101 tempP%array6 = tempP%array6 /tempP_indic%array6 1102 END WHERE 1097 1103 1098 1104 deallocate(tempP_indic%array6) … … 1319 1325 integer, intent(in) :: nbdim 1320 1326 integer, dimension(nbdim), intent(out) :: indmin, indmax 1321 real (kind=8), dimension(nbdim), intent(out) :: s_Parent_temp, s_Child_temp1322 real (kind=8), dimension(nbdim), intent(in) :: s_child, ds_child1323 real (kind=8), dimension(nbdim), intent(in) :: s_parent, ds_parent1327 real, dimension(nbdim), intent(out) :: s_Parent_temp, s_Child_temp 1328 real, dimension(nbdim), intent(in) :: s_child, ds_child 1329 real, dimension(nbdim), intent(in) :: s_parent, ds_parent 1324 1330 integer, dimension(nbdim), intent(in) :: pttruetab, cetruetab 1325 1331 integer, dimension(nbdim), intent(in) :: lb_child, lb_parent … … 1331 1337 #endif 1332 1338 ! 1333 real (kind=8),dimension(nbdim) :: dim_newmin,dim_newmax1339 real,dimension(nbdim) :: dim_newmin,dim_newmax 1334 1340 integer :: i 1335 1341 #if defined AGRIF_MPI 1336 real (kind=8):: positionmin, positionmax1342 real :: positionmin, positionmax 1337 1343 integer :: imin, imax 1338 1344 integer :: coeffraf … … 1351 1357 IF ( do_update(i) ) THEN 1352 1358 IF (posvar(i) == 1) THEN 1353 IF (type_update(i) == Agrif_Update_Average) THEN1359 IF ((type_update(i) == Agrif_Update_Average).OR.(type_update(i) == Agrif_Update_Max)) THEN 1354 1360 positionmin = positionmin - ds_parent(i)/2. 1355 1361 ELSE IF (type_update(i) == Agrif_Update_Full_Weighting) THEN … … 1377 1383 IF ( do_update(i) ) THEN 1378 1384 IF (posvar(i) == 1) THEN 1379 IF (type_update(i) == Agrif_Update_Average) THEN1385 IF ((type_update(i) == Agrif_Update_Average).OR.(type_update(i) == Agrif_Update_Max)) THEN 1380 1386 positionmax = positionmax + ds_parent(i)/2. 1381 1387 ELSE IF (type_update(i) == Agrif_Update_Full_Weighting) THEN … … 1418 1424 !> Updates a 1D grid variable on the parent grid 1419 1425 !--------------------------------------------------------------------------------------------------- 1420 subroutine Agrif_Update_1D_Recursive ( type_update, 1421 tempP, tempC, tempC_indic,&1422 indmin, indmax, 1423 lb_child, ub_child, 1424 s_child, s_parent, 1426 subroutine Agrif_Update_1D_Recursive ( type_update, & 1427 tempP, tempC, & 1428 indmin, indmax, & 1429 lb_child, ub_child, & 1430 s_child, s_parent, & 1425 1431 ds_child, ds_parent ) 1426 1432 !--------------------------------------------------------------------------------------------------- … … 1428 1434 integer, intent(in) :: indmin, indmax 1429 1435 integer, intent(in) :: lb_child, ub_child 1430 real (kind=8), intent(in) :: s_child, s_parent1431 real (kind=8), intent(in) :: ds_child, ds_parent1436 real, intent(in) :: s_child, s_parent 1437 real, intent(in) :: ds_child, ds_parent 1432 1438 real, dimension(indmin:indmax), intent(out) :: tempP 1433 real, dimension(lb_child:ub_child), intent(in) :: tempC , tempC_indic1439 real, dimension(lb_child:ub_child), intent(in) :: tempC 1434 1440 !--------------------------------------------------------------------------------------------------- 1435 1441 call Agrif_UpdateBase(type_update, & … … 1450 1456 !! Calls #Agrif_Update_1D_Recursive and #Agrif_UpdateBase 1451 1457 !--------------------------------------------------------------------------------------------------- 1452 subroutine Agrif_Update_2D_Recursive ( type_update, 1453 tempP, tempC, tempC_indic,&1454 indmin, indmax, 1455 lb_child, ub_child, 1456 s_child, s_parent,&1458 subroutine Agrif_Update_2D_Recursive ( type_update, & 1459 tempP, tempC, & 1460 indmin, indmax, & 1461 lb_child, ub_child, & 1462 s_child, s_parent, & 1457 1463 ds_child, ds_parent ) 1458 1464 !--------------------------------------------------------------------------------------------------- … … 1460 1466 integer, dimension(2), intent(in) :: indmin, indmax 1461 1467 integer, dimension(2), intent(in) :: lb_child, ub_child 1462 real (kind=8), dimension(2), intent(in) :: s_child, s_parent1463 real (kind=8), dimension(2), intent(in) :: ds_child, ds_parent1468 real, dimension(2), intent(in) :: s_child, s_parent 1469 real, dimension(2), intent(in) :: ds_child, ds_parent 1464 1470 real, dimension( & 1465 1471 indmin(1):indmax(1), & 1466 1472 indmin(2):indmax(2)), intent(out) :: tempP 1467 real, dimension(:,:), intent(in) :: tempC , tempC_indic1473 real, dimension(:,:), intent(in) :: tempC 1468 1474 !--------------------------------------------------------------------------------------------------- 1469 1475 real, dimension(indmin(1):indmax(1), lb_child(2):ub_child(2)) :: tabtemp … … 1471 1477 real, dimension(lb_child(2):ub_child(2), indmin(1):indmax(1)) :: tabtemp_trsp 1472 1478 integer :: i, j 1473 integer :: coeffraf, coeffraf_2 1474 integer :: jmin,jmax 1475 integer locind_child_left, locind_child_left_2,kuinf 1476 logical :: to_transpose 1477 real :: invcoeffraf 1478 integer :: diffmod, jj,i1,j1 1479 1480 1481 to_transpose = .TRUE. 1482 ! 1483 1479 integer :: coeffraf 1480 ! 1481 tabtemp = 0. 1484 1482 coeffraf = nint ( ds_parent(1) / ds_child(1) ) 1485 1483 ! … … 1494 1492 endif 1495 1493 !---CDIR NEXPAND 1496 tabtemp = 0.1497 1494 call Average1dAfterCompute( tabtemp, tempC, size(tabtemp), size(tempC), & 1498 1495 s_parent(1),s_child(1),ds_parent(1),ds_child(1),1) … … 1508 1505 endif 1509 1506 !---CDIR NEXPAND 1510 1511 1507 call Agrif_basicupdate_copy1d_after(tabtemp,tempC,size(tabtemp),size(tempC),1) 1512 1508 ! 1513 ELSE IF ((coeffraf == 1).AND.(type_update(2) == Agrif_Update_Average)) THEN1514 locind_child_left = 1+agrif_int((s_parent(1)-s_child(1))/ds_child(1))1515 coeffraf_2 = nint ( ds_parent(2) / ds_child(2) )1516 invcoeffraf = 1./coeffraf_21517 tempP = 0.1518 diffmod = 01519 if (mod(coeffraf_2,2) == 0) diffmod = 11520 locind_child_left_2 = 1+agrif_int((s_parent(2)-s_child(2))/ds_child(2))1521 1522 if (Agrif_UseSpecialValueInUpdate) then1523 j1 = -coeffraf_2/2+locind_child_left_2+diffmod1524 do j=indmin(2),indmax(2)1525 do jj=j1,j1+coeffraf_2-11526 i1 = locind_child_left1527 do i=indmin(1),indmax(1)1528 tempP(i,j) = tempP(i,j) + tempC(i1,jj)*tempC_indic(i1,jj)1529 i1 = i1 + 11530 enddo1531 enddo1532 j1 = j1 + coeffraf_21533 enddo1534 else1535 j1 = -coeffraf_2/2+locind_child_left_2+diffmod1536 do j=indmin(2),indmax(2)1537 do jj=j1,j1+coeffraf_2-11538 do i=indmin(1),indmax(1)1539 tempP(i,j) = tempP(i,j) + tempC(locind_child_left+i-indmin(1),jj)1540 enddo1541 enddo1542 j1 = j1 + coeffraf_21543 enddo1544 if (.not.Agrif_Update_Weights) tempP = tempP * invcoeffraf1545 endif1546 return1547 !1548 ELSE IF ((coeffraf == 1).AND.(type_update(2) == Agrif_Update_Copy)) THEN1549 1550 locind_child_left = 1 + agrif_int((s_parent(1)-s_child(1))/ds_child(1))1551 !1552 locind_child_left_2 = 1+nint((s_parent(2)-s_child(2))/ds_child(2))1553 coeffraf_2 = nint ( ds_parent(2) / ds_child(2) )1554 1555 do j=indmin(2),indmax(2)1556 do i=indmin(1),indmax(1)1557 tempP(i,j) = tempC(locind_child_left+i-indmin(1),locind_child_left_2)1558 enddo1559 locind_child_left_2 = locind_child_left_2 + coeffraf_21560 enddo1561 1562 return1563 1564 ELSE IF (coeffraf == 1) THEN1565 locind_child_left = 1 + agrif_int((s_parent(1)-s_child(1))/ds_child(1))1566 !1567 do j = lb_child(2),ub_child(2)1568 ! tabtemp(indmin(1):indmax(1),j) = tempC(locind_child_left:locind_child_left+indmax(1)-indmin(1),j-lb_child(2)+1)1569 tabtemp_trsp(j,indmin(1):indmax(1)) = tempC(locind_child_left:locind_child_left+indmax(1)-indmin(1),j-lb_child(2)+1)1570 enddo1571 to_transpose = .FALSE.1572 1509 ELSE 1573 1510 do j = lb_child(2),ub_child(2) … … 1577 1514 tabtemp(:,j), & 1578 1515 tempC(:,j-lb_child(2)+1), & 1579 tempC_indic(:,j-lb_child(2)+1), &1580 1516 indmin(1), indmax(1), & 1581 1517 lb_child(1),ub_child(1), & … … 1585 1521 ENDIF 1586 1522 ! 1587 1588 if (to_transpose) tabtemp_trsp = TRANSPOSE(tabtemp) 1589 1523 tabtemp_trsp = TRANSPOSE(tabtemp) 1590 1524 coeffraf = nint(ds_parent(2)/ds_child(2)) 1591 1525 ! … … 1632 1566 ENDIF 1633 1567 ! 1634 1635 1636 1568 tempP = TRANSPOSE(tempP_trsp) 1637 1569 !--------------------------------------------------------------------------------------------------- 1638 1570 end subroutine Agrif_Update_2D_Recursive 1571 !=================================================================================================== 1572 ! 1573 subroutine Agrif_Update_2D_Recursive_ok ( type_update, & 1574 tempP, tempC, & 1575 indmin, indmax, & 1576 lb_child, ub_child, & 1577 s_child, s_parent, ds_child, ds_parent ) 1578 !--------------------------------------------------------------------------------------------------- 1579 INTEGER, DIMENSION(2), intent(in) :: type_update !< Type of update (copy or average) 1580 INTEGER, DIMENSION(2), intent(in) :: indmin, indmax 1581 INTEGER, DIMENSION(2), intent(in) :: lb_child, ub_child 1582 REAL, DIMENSION(2), intent(in) :: s_child, s_parent 1583 REAL, DIMENSION(2), intent(in) :: ds_child, ds_parent 1584 REAL, DIMENSION( & 1585 indmin(1):indmax(1), & 1586 indmin(2):indmax(2)), intent(out) :: tempP 1587 REAL, DIMENSION( & 1588 lb_child(1):ub_child(1), & 1589 lb_child(2):ub_child(2)), intent(in) :: tempC 1590 ! 1591 REAL, DIMENSION(indmin(1):indmax(1), lb_child(2):ub_child(2)) :: tabtemp 1592 INTEGER :: i 1593 ! 1594 do i = lb_child(2),ub_child(2) 1595 call Agrif_Update_1D_Recursive(type_update(1), & 1596 tabtemp(:, i), & 1597 tempC(:,i), & 1598 indmin(1),indmax(1), & 1599 lb_child(1),ub_child(1), & 1600 s_child(1), s_parent(1), & 1601 ds_child(1),ds_parent(1)) 1602 enddo 1603 ! 1604 tempP = 0. 1605 ! 1606 do i = indmin(1),indmax(1) 1607 call Agrif_UpdateBase(type_update(2), & 1608 tempP(i,:), & 1609 tabtemp(i,:), & 1610 indmin(2),indmax(2), & 1611 lb_child(2),ub_child(2), & 1612 s_parent(2),s_child(2), & 1613 ds_parent(2),ds_child(2)) 1614 enddo 1615 !--------------------------------------------------------------------------------------------------- 1616 end subroutine Agrif_Update_2D_Recursive_ok 1639 1617 !=================================================================================================== 1640 1618 … … 1646 1624 !! Calls #Agrif_Update_2D_Recursive and #Agrif_UpdateBase. 1647 1625 !--------------------------------------------------------------------------------------------------- 1648 subroutine Agrif_Update_3D_Recursive ( type_update, 1649 tempP, tempC, tempC_indic,&1650 indmin, indmax, 1651 lb_child, ub_child, 1652 s_child, s_parent,&1626 subroutine Agrif_Update_3D_Recursive ( type_update, & 1627 tempP, tempC, & 1628 indmin, indmax, & 1629 lb_child, ub_child, & 1630 s_child, s_parent, & 1653 1631 ds_child, ds_parent ) 1654 1632 !--------------------------------------------------------------------------------------------------- … … 1656 1634 integer, dimension(3), intent(in) :: indmin, indmax 1657 1635 integer, dimension(3), intent(in) :: lb_child, ub_child 1658 real (kind=8), dimension(3), intent(in) :: s_child, s_parent1659 real (kind=8), dimension(3), intent(in) :: ds_child, ds_parent1636 real, dimension(3), intent(in) :: s_child, s_parent 1637 real, dimension(3), intent(in) :: ds_child, ds_parent 1660 1638 real, dimension( & 1661 1639 indmin(1):indmax(1), & … … 1665 1643 lb_child(1):ub_child(1), & 1666 1644 lb_child(2):ub_child(2), & 1667 lb_child(3):ub_child(3)), intent(in) :: tempC , tempC_indic1645 lb_child(3):ub_child(3)), intent(in) :: tempC 1668 1646 !--------------------------------------------------------------------------------------------------- 1669 1647 real, dimension( & … … 1674 1652 integer :: coeffraf,locind_child_left 1675 1653 integer :: kuinf 1676 REAL :: invcoeffraf1677 INTEGER :: diffmod, kk1678 1654 ! 1679 1655 coeffraf = nint ( ds_parent(1) / ds_child(1) ) … … 1713 1689 endif 1714 1690 ! 1715 ! do k = lb_child(3),ub_child(3)1716 ! call Agrif_Update_2D_Recursive( type_update(1:2),tabtemp(:,:,k),tempC(:,:,k), &1717 ! indmin(1:2),indmax(1:2), &1718 ! lb_child(1:2),ub_child(1:2), &1719 ! s_child(1:2),s_parent(1:2), &1720 ! ds_child(1:2),ds_parent(1:2) )1721 ! enddo1722 1723 1724 1691 do k = lb_child(3),ub_child(3) 1725 call Agrif_Update_2D_Recursive( type_update,tabtemp(:,:,k),tempC(:,:,k),tempC_indic(:,:,k), & 1726 indmin,indmax, & 1727 lb_child,ub_child, & 1728 s_child,s_parent, & 1729 ds_child,ds_parent) 1730 enddo 1731 1692 call Agrif_Update_2D_Recursive( type_update(1:2),tabtemp(:,:,k),tempC(:,:,k), & 1693 indmin(1:2),indmax(1:2), & 1694 lb_child(1:2),ub_child(1:2), & 1695 s_child(1:2),s_parent(1:2), & 1696 ds_child(1:2),ds_parent(1:2) ) 1697 enddo 1732 1698 ! 1733 1699 precomputedone(1) = .FALSE. … … 1747 1713 enddo 1748 1714 enddo 1749 else if (type_update(3) == Agrif_Update_Copy) then1750 locind_child_left = lb_child(3) + nint((s_parent(3)-s_child(3))/ds_child(3))1751 1752 do k=indmin(3),indmax(3)1753 do j = indmin(2),indmax(2)1754 do i = indmin(1),indmax(1)1755 tempP(i,j,k) = tabtemp(i,j,locind_child_left)1756 enddo1757 enddo1758 locind_child_left = locind_child_left + coeffraf1759 enddo1760 else if (type_update(3) == Agrif_Update_Average) then1761 invcoeffraf = 1./coeffraf1762 tempP = 0.1763 diffmod = 01764 if (mod(coeffraf,2) == 0) diffmod=11765 locind_child_left = lb_child(3) + agrif_int((s_parent(3)-s_child(3))/ds_child(3))1766 if (Agrif_UseSpecialValueInUpdate) then1767 do k=indmin(3),indmax(3)1768 do kk=-coeffraf/2+locind_child_left+diffmod, &1769 coeffraf/2+locind_child_left1770 do j=indmin(2),indmax(2)1771 do i=indmin(1),indmax(1)1772 if (tabtemp(i,j,kk) /= Agrif_SpecialValueFineGrid) then1773 tempP(i,j,k) = tempP(i,j,k) + tabtemp(i,j,kk)1774 endif1775 enddo1776 enddo1777 enddo1778 locind_child_left = locind_child_left + coeffraf1779 enddo1780 else1781 do k=indmin(3),indmax(3)1782 do kk=-coeffraf/2+locind_child_left+diffmod, &1783 coeffraf/2+locind_child_left1784 do j=indmin(2),indmax(2)1785 do i=indmin(1),indmax(1)1786 tempP(i,j,k) = tempP(i,j,k) + tabtemp(i,j,kk)1787 enddo1788 enddo1789 enddo1790 locind_child_left = locind_child_left + coeffraf1791 enddo1792 if (.not.Agrif_Update_Weights) tempP = tempP * invcoeffraf1793 endif1794 1715 else 1716 tempP = 0. 1795 1717 do j = indmin(2),indmax(2) 1796 1718 do i = indmin(1),indmax(1) … … 1800 1722 s_parent(3),s_child(3), & 1801 1723 ds_parent(3),ds_child(3)) 1802 1724 ! 1803 1725 enddo 1804 1726 enddo 1805 1806 1807 1727 endif 1808 1728 !--------------------------------------------------------------------------------------------------- … … 1816 1736 !! Calls #Agrif_Update_3D_Recursive and #Agrif_UpdateBase. 1817 1737 !--------------------------------------------------------------------------------------------------- 1818 subroutine Agrif_Update_4D_Recursive ( type_update, 1819 tempP, tempC, tempC_indic,&1820 indmin, indmax, 1821 lb_child, ub_child, 1822 s_child, s_parent,&1738 subroutine Agrif_Update_4D_Recursive ( type_update, & 1739 tempP, tempC, & 1740 indmin, indmax, & 1741 lb_child, ub_child, & 1742 s_child, s_parent, & 1823 1743 ds_child, ds_parent ) 1824 1744 !--------------------------------------------------------------------------------------------------- … … 1826 1746 integer, dimension(4), intent(in) :: indmin, indmax 1827 1747 integer, dimension(4), intent(in) :: lb_child, ub_child 1828 real (kind=8), dimension(4), intent(in) :: s_child, s_parent1829 real (kind=8), dimension(4), intent(in) :: ds_child, ds_parent1748 real, dimension(4), intent(in) :: s_child, s_parent 1749 real, dimension(4), intent(in) :: ds_child, ds_parent 1830 1750 real, dimension( & 1831 1751 indmin(1):indmax(1), & … … 1837 1757 lb_child(2):ub_child(2), & 1838 1758 lb_child(3):ub_child(3), & 1839 lb_child(4):ub_child(4)), intent(in) :: tempC , tempC_indic1759 lb_child(4):ub_child(4)), intent(in) :: tempC 1840 1760 !--------------------------------------------------------------------------------------------------- 1841 1761 real, dimension(:,:,:,:), allocatable :: tabtemp … … 1853 1773 indmin(3):indmax(3), l), & 1854 1774 tempC(lb_child(1):ub_child(1), & 1855 lb_child(2):ub_child(2), &1856 lb_child(3):ub_child(3), l), &1857 tempC_indic(lb_child(1):ub_child(1), &1858 1775 lb_child(2):ub_child(2), & 1859 1776 lb_child(3):ub_child(3), l), & … … 1891 1808 !! Calls #Agrif_Update_4D_Recursive and #Agrif_UpdateBase. 1892 1809 !--------------------------------------------------------------------------------------------------- 1893 subroutine Agrif_Update_5D_Recursive ( type_update, 1894 tempP, tempC, tempC_indic,&1895 indmin, indmax, 1896 lb_child, ub_child, 1897 s_child, s_parent,&1810 subroutine Agrif_Update_5D_Recursive ( type_update, & 1811 tempP, tempC, & 1812 indmin, indmax, & 1813 lb_child, ub_child, & 1814 s_child, s_parent, & 1898 1815 ds_child, ds_parent ) 1899 1816 !--------------------------------------------------------------------------------------------------- … … 1901 1818 integer, dimension(5), intent(in) :: indmin, indmax 1902 1819 integer, dimension(5), intent(in) :: lb_child, ub_child 1903 real (kind=8), dimension(5), intent(in) :: s_child, s_parent1904 real (kind=8), dimension(5), intent(in) :: ds_child, ds_parent1820 real, dimension(5), intent(in) :: s_child, s_parent 1821 real, dimension(5), intent(in) :: ds_child, ds_parent 1905 1822 real, dimension( & 1906 1823 indmin(1):indmax(1), & … … 1914 1831 lb_child(3):ub_child(3), & 1915 1832 lb_child(4):ub_child(4), & 1916 lb_child(5):ub_child(5)), intent(in) :: tempC , tempC_indic1833 lb_child(5):ub_child(5)), intent(in) :: tempC 1917 1834 !--------------------------------------------------------------------------------------------------- 1918 1835 real, dimension(:,:,:,:,:), allocatable :: tabtemp … … 1932 1849 indmin(4):indmax(4), m), & 1933 1850 tempC(lb_child(1):ub_child(1), & 1934 lb_child(2):ub_child(2), &1935 lb_child(3):ub_child(3), &1936 lb_child(4):ub_child(4), m), &1937 tempC_indic(lb_child(1):ub_child(1), &1938 1851 lb_child(2):ub_child(2), & 1939 1852 lb_child(3):ub_child(3), & … … 1974 1887 !! Calls #Agrif_Update_5D_Recursive and #Agrif_UpdateBase. 1975 1888 !--------------------------------------------------------------------------------------------------- 1976 subroutine Agrif_Update_6D_Recursive ( type_update, 1977 tempP, tempC, tempC_indic,&1978 indmin, indmax, 1979 lb_child, ub_child, 1980 s_child, s_parent,&1889 subroutine Agrif_Update_6D_Recursive ( type_update, & 1890 tempP, tempC, & 1891 indmin, indmax, & 1892 lb_child, ub_child, & 1893 s_child, s_parent, & 1981 1894 ds_child, ds_parent ) 1982 1895 !--------------------------------------------------------------------------------------------------- … … 1984 1897 integer, dimension(6), intent(in) :: indmin, indmax 1985 1898 integer, dimension(6), intent(in) :: lb_child, ub_child 1986 real (kind=8), dimension(6), intent(in) :: s_child, s_parent1987 real (kind=8), dimension(6), intent(in) :: ds_child, ds_parent1899 real, dimension(6), intent(in) :: s_child, s_parent 1900 real, dimension(6), intent(in) :: ds_child, ds_parent 1988 1901 real, dimension( & 1989 1902 indmin(1):indmax(1), & … … 1999 1912 lb_child(4):ub_child(4), & 2000 1913 lb_child(5):ub_child(5), & 2001 lb_child(6):ub_child(6)), intent(in) :: tempC , tempC_indic1914 lb_child(6):ub_child(6)), intent(in) :: tempC 2002 1915 !--------------------------------------------------------------------------------------------------- 2003 1916 real, dimension(:,:,:,:,:,:), allocatable :: tabtemp … … 2023 1936 lb_child(4):ub_child(4), & 2024 1937 lb_child(5):ub_child(5), n), & 2025 tempC_indic(lb_child(1):ub_child(1), &2026 lb_child(2):ub_child(2), &2027 lb_child(3):ub_child(3), &2028 lb_child(4):ub_child(4), &2029 lb_child(5):ub_child(5), n), &2030 1938 indmin(1:5), indmax(1:5), & 2031 1939 lb_child(1:5),ub_child(1:5), & … … 2076 1984 real, dimension(indmin:indmax), intent(out):: parent_tab 2077 1985 real, dimension(lb_child:ub_child), intent(in) :: child_tab 2078 real (kind=8),intent(in) :: s_parent, s_child2079 real (kind=8),intent(in) :: ds_parent, ds_child1986 real, intent(in) :: s_parent, s_child 1987 real, intent(in) :: ds_parent, ds_child 2080 1988 !--------------------------------------------------------------------------------------------------- 2081 1989 integer :: np ! Length of parent array … … 2101 2009 ds_parent, ds_child ) 2102 2010 ! 2011 elseif ( type_update == Agrif_Update_Max ) then 2012 ! 2013 call Agrif_basicupdate_max1d( & 2014 parent_tab, child_tab, & 2015 np, nc, & 2016 s_parent, s_child, & 2017 ds_parent, ds_child ) 2103 2018 elseif ( type_update == Agrif_Update_Full_Weighting ) then 2104 2019 ! -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modupdatebasic.F90
r10087 r10725 49 49 integer, intent(in) :: np !< Length of parent array 50 50 integer, intent(in) :: nc !< Length of child array 51 real (kind=8),intent(in) :: s_parent !< Parent grid position (s_root = 0)52 real (kind=8),intent(in) :: s_child !< Child grid position (s_root = 0)53 real (kind=8),intent(in) :: ds_parent !< Parent grid dx (ds_root = 1)54 real (kind=8),intent(in) :: ds_child !< Child grid dx (ds_root = 1)51 real, intent(in) :: s_parent !< Parent grid position (s_root = 0) 52 real, intent(in) :: s_child !< Child grid position (s_root = 0) 53 real, intent(in) :: ds_parent !< Parent grid dx (ds_root = 1) 54 real, intent(in) :: ds_child !< Child grid dx (ds_root = 1) 55 55 !--------------------------------------------------------------------------------------------------- 56 56 integer :: i, locind_child_left, coeffraf … … 84 84 integer, intent(in) :: np !< Length of parent array 85 85 integer, intent(in) :: nc !< Length of child array 86 real (kind=8),intent(in) :: s_parent !< Parent grid position (s_root = 0)87 real (kind=8),intent(in) :: s_child !< Child grid position (s_root = 0)88 real (kind=8),intent(in) :: ds_parent !< Parent grid dx (ds_root = 1)89 real (kind=8),intent(in) :: ds_child !< Child grid dx (ds_root = 1)86 real, intent(in) :: s_parent !< Parent grid position (s_root = 0) 87 real, intent(in) :: s_child !< Child grid position (s_root = 0) 88 real, intent(in) :: ds_parent !< Parent grid dx (ds_root = 1) 89 real, intent(in) :: ds_child !< Child grid dx (ds_root = 1) 90 90 integer, intent(in) :: dir !< Direction 91 91 !--------------------------------------------------------------------------------------------------- … … 157 157 REAL, DIMENSION(nc), intent(in) :: y 158 158 INTEGER, intent(in) :: np,nc 159 REAL (kind=8),intent(in) :: s_parent, s_child160 REAL (kind=8),intent(in) :: ds_parent, ds_child159 REAL, intent(in) :: s_parent, s_child 160 REAL, intent(in) :: ds_parent, ds_child 161 161 ! 162 162 INTEGER :: i, ii, locind_child_left, coeffraf 163 REAL(kind=8) :: xpos 164 REAL :: invcoeffraf 163 REAL :: xpos, invcoeffraf 165 164 INTEGER :: nbnonnuls 166 165 INTEGER :: diffmod … … 221 220 end subroutine Agrif_basicupdate_average1d 222 221 !=================================================================================================== 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 !--------------------------------------------------------------------------------------------------- 228 subroutine 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 !--------------------------------------------------------------------------------------------------- 284 end subroutine Agrif_basicupdate_max1d 285 !=================================================================================================== 286 223 287 ! 224 288 !=================================================================================================== … … 230 294 !--------------------------------------------------------------------------------------------------- 231 295 INTEGER, intent(in) :: nc2, np, nc 232 REAL (kind=8), intent(in) :: s_parent, s_child233 REAL (kind=8), intent(in) :: ds_parent, ds_child296 REAL, intent(in) :: s_parent, s_child 297 REAL, intent(in) :: ds_parent, ds_child 234 298 INTEGER, intent(in) :: dir 235 299 ! 236 300 INTEGER, DIMENSION(:,:), ALLOCATABLE :: indchildaverage_tmp 237 301 INTEGER :: i, locind_child_left, coeffraf 238 REAL (kind=8):: xpos302 REAL :: xpos 239 303 INTEGER :: diffmod 240 304 ! … … 282 346 REAL, DIMENSION(nc), intent(in) :: y 283 347 INTEGER, intent(in) :: np, nc 284 REAL (kind=8), intent(in) :: s_parent, s_child285 REAL (kind=8), intent(in) :: ds_parent, ds_child348 REAL, intent(in) :: s_parent, s_child 349 REAL, intent(in) :: ds_parent, ds_child 286 350 INTEGER, intent(in) :: dir 287 351 ! … … 312 376 ELSE 313 377 ! 314 315 do i = 1,np 316 do j = 1,coeffraf 378 !CDIR NOLOOPCHG 379 do j = 1,coeffraf 380 !CDIR VECTOR 381 do i= 1,np 317 382 x(i) = x(i) + y(indchildaverage(i,dir) + j-1 ) 318 enddo383 enddo 319 384 enddo 320 385 IF (.not.Agrif_Update_Weights) THEN … … 338 403 real, dimension(nc), intent(in) :: y 339 404 integer, intent(in) :: np, nc 340 real (kind=8), intent(in) :: s_parent, s_child341 real (kind=8), intent(in) :: ds_parent, ds_child342 !--------------------------------------------------------------------------------------------------- 343 REAL (kind=8):: xpos, xposfin405 real, intent(in) :: s_parent, s_child 406 real, intent(in) :: ds_parent, ds_child 407 !--------------------------------------------------------------------------------------------------- 408 REAL :: xpos, xposfin 344 409 INTEGER :: i, ii, diffmod 345 410 INTEGER :: it1, it2 -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modutil.F90
r10087 r10725 2 2 ! $Id$ 3 3 ! 4 ! A GRIF(Adaptive Grid Refinement In Fortran)4 ! Agrif (Adaptive Grid Refinement In Fortran) 5 5 ! 6 6 ! Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr) … … 19 19 ! You should have received a copy of the GNU General Public License 20 20 ! along with this program; if not, write to the Free Software 21 ! Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA.21 ! Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA. 22 22 ! 23 23 !> Module Agrif_Util 24 !> 25 !> 26 ! 24 !! 25 !! This module contains the two procedures called in the main program : 26 !! - #Agrif_Init_Grids allows the initialization of the root coarse grid 27 !! - #Agrif_Step allows the creation of the grid hierarchy and the management of the time integration. 27 28 ! 28 29 module Agrif_Util 29 30 ! 30 use Agrif_User_Hierarchy 31 use Agrif_User_Variables 32 use Agrif_user_Functions 33 use Agrif_user_Interpolation 34 use Agrif_user_Update 35 31 use Agrif_Clustering 32 use Agrif_BcFunction 33 use Agrif_seq 36 34 ! 37 35 implicit none 38 36 ! 37 abstract interface 38 subroutine step_proc() 39 end subroutine step_proc 40 end interface 41 ! 39 42 contains 40 43 ! 41 44 !=================================================================================================== 45 ! subroutine Agrif_Step 46 ! 47 !> Creates the grid hierarchy and manages the time integration procedure. 48 !> It is called in the main program. 49 !> Calls subroutines #Agrif_Regrid and #Agrif_Integrate. 50 !--------------------------------------------------------------------------------------------------- 51 subroutine Agrif_Step ( procname ) 52 !--------------------------------------------------------------------------------------------------- 53 procedure(step_proc) :: procname !< subroutine to call on each grid 54 type(agrif_grid), pointer :: ref_grid 55 ! 56 ! Set the clustering variables 57 call Agrif_clustering_def() 58 ! 59 ! Creation and initialization of the grid hierarchy 60 if ( Agrif_USE_ONLY_FIXED_GRIDS == 1 ) then 61 ! 62 if ( (Agrif_Mygrid % ngridstep == 0) .AND. (.not. Agrif_regrid_has_been_done) ) then 63 call Agrif_Regrid() 64 Agrif_regrid_has_been_done = .TRUE. 65 endif 66 ! 67 else 68 ! 69 if (mod(Agrif_Mygrid % ngridstep,Agrif_Regridding) == 0) then 70 call Agrif_Regrid() 71 endif 72 ! 73 endif 74 ! 75 ! Time integration of the grid hierarchy 76 if (agrif_coarse) then 77 ref_grid => agrif_coarsegrid 78 else 79 ref_grid => agrif_mygrid 80 endif 81 if ( Agrif_Parallel_sisters ) then 82 call Agrif_Integrate_Parallel(ref_grid,procname) 83 else 84 call Agrif_Integrate(ref_grid,procname) 85 endif 86 ! 87 if ( ref_grid%child_list%nitems > 0 ) call Agrif_Instance(ref_grid) 88 !--------------------------------------------------------------------------------------------------- 89 end subroutine Agrif_Step 90 !=================================================================================================== 91 ! 92 !=================================================================================================== 93 ! subroutine Agrif_Step_Child 94 ! 95 !> Apply 'procname' to each grid of the hierarchy 96 !--------------------------------------------------------------------------------------------------- 97 subroutine Agrif_Step_Child ( procname ) 98 !--------------------------------------------------------------------------------------------------- 99 procedure(step_proc) :: procname !< subroutine to call on each grid 100 ! 101 if ( Agrif_Parallel_sisters ) then 102 call Agrif_Integrate_Child_Parallel(Agrif_Mygrid,procname) 103 else 104 call Agrif_Integrate_Child(Agrif_Mygrid,procname) 105 endif 106 ! 107 if ( Agrif_Mygrid%child_list%nitems > 0 ) call Agrif_Instance(Agrif_Mygrid) 108 !--------------------------------------------------------------------------------------------------- 109 end 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 152 !=================================================================================================== 153 ! 154 !=================================================================================================== 155 ! subroutine Agrif_Regrid 156 ! 157 !> Creates the grid hierarchy from fixed grids and adaptive mesh refinement. 158 !--------------------------------------------------------------------------------------------------- 159 subroutine Agrif_Regrid ( procname ) 160 !--------------------------------------------------------------------------------------------------- 161 procedure(init_proc), optional :: procname !< Initialisation subroutine (Default: Agrif_InitValues) 162 ! 163 type(Agrif_Rectangle), pointer :: coarsegrid_fixed 164 type(Agrif_Rectangle), pointer :: coarsegrid_moving 165 integer :: i, j 166 integer :: nunit 167 logical :: BEXIST 168 TYPE(Agrif_Rectangle) :: newrect ! Pointer on a new grid 169 integer :: is_coarse, rhox, rhoy, rhoz, rhot 170 ! 171 if ( Agrif_USE_ONLY_FIXED_GRIDS == 0 ) & 172 call Agrif_detect_all(Agrif_Mygrid) ! Detection of areas to be refined 173 ! 174 allocate(coarsegrid_fixed) 175 allocate(coarsegrid_moving) 176 ! 177 if ( Agrif_USE_ONLY_FIXED_GRIDS == 0 ) & 178 call Agrif_Cluster_All(Agrif_Mygrid,coarsegrid_moving) ! Clustering 179 ! 180 if ( Agrif_USE_FIXED_GRIDS == 1 .OR. Agrif_USE_ONLY_FIXED_GRIDS == 1 ) then 181 ! 182 if (Agrif_Mygrid % ngridstep == 0) then 183 ! 184 nunit = Agrif_Get_Unit() 185 open(nunit, file='AGRIF_FixedGrids.in', form='formatted', status="old", ERR=99) 186 if (agrif_coarse) then ! SKIP the coarse grid declaration 187 if (Agrif_Probdim == 3) then 188 read(nunit,*) is_coarse, rhox, rhoy, rhoz, rhot 189 elseif (Agrif_Probdim == 2) then 190 read(nunit,*) is_coarse, rhox, rhoy, rhot 191 elseif (Agrif_Probdim == 2) then 192 read(nunit,*) is_coarse, rhox, rhot 193 endif 194 endif 195 ! Creation of the grid hierarchy from the Agrif_FixedGrids.in file 196 do i = 1,Agrif_Probdim 197 coarsegrid_fixed % imin(i) = 1 198 coarsegrid_fixed % imax(i) = Agrif_Mygrid % nb(i) + 1 199 enddo 200 j = 1 201 call Agrif_Read_Fix_Grd(coarsegrid_fixed,j,nunit) 202 close(nunit) 203 ! 204 call Agrif_gl_clear(Agrif_oldmygrid) 205 ! 206 ! Creation of the grid hierarchy from coarsegrid_fixed 207 call Agrif_Create_Grids(Agrif_Mygrid,coarsegrid_fixed) 208 209 else 210 call Agrif_gl_copy(Agrif_oldmygrid, Agrif_Mygrid % child_list) 211 endif 212 else 213 call Agrif_gl_copy(Agrif_oldmygrid, Agrif_Mygrid % child_list) 214 call Agrif_gl_clear(Agrif_Mygrid % child_list) 215 endif 216 ! 217 if ( Agrif_USE_ONLY_FIXED_GRIDS == 0 ) then 218 ! 219 call Agrif_Save_All(Agrif_oldmygrid) 220 call Agrif_Free_before_All(Agrif_oldmygrid) 221 ! 222 ! Creation of the grid hierarchy from coarsegrid_moving 223 call Agrif_Create_Grids(Agrif_Mygrid,coarsegrid_moving) 224 ! 225 endif 226 ! 227 ! Initialization of the grid hierarchy by copy or interpolation 228 ! 229 #if defined AGRIF_MPI 230 if ( Agrif_Parallel_sisters ) then 231 call Agrif_Init_Hierarchy_Parallel_1(Agrif_Mygrid) 232 call Agrif_Init_Hierarchy_Parallel_2(Agrif_Mygrid,procname) 233 else 234 call Agrif_Init_Hierarchy(Agrif_Mygrid,procname) 235 endif 236 #else 237 call Agrif_Init_Hierarchy(Agrif_Mygrid,procname) 238 #endif 239 ! 240 if ( Agrif_USE_ONLY_FIXED_GRIDS == 0 ) call Agrif_Free_after_All(Agrif_oldmygrid) 241 ! 242 Agrif_regrid_has_been_done = .TRUE. 243 ! 244 call Agrif_Instance( Agrif_Mygrid ) 245 ! 246 deallocate(coarsegrid_fixed) 247 deallocate(coarsegrid_moving) 248 ! 249 return 250 ! 251 ! Opening error 252 ! 253 99 INQUIRE(FILE='AGRIF_FixedGrids.in',EXIST=BEXIST) 254 if (.not. BEXIST) then 255 print*,'ERROR : File AGRIF_FixedGrids.in not found.' 256 STOP 257 else 258 print*,'Error opening file AGRIF_FixedGrids.in' 259 STOP 260 endif 261 !--------------------------------------------------------------------------------------------------- 262 end subroutine Agrif_Regrid 263 !=================================================================================================== 264 ! 265 !=================================================================================================== 266 ! subroutine Agrif_detect_All 267 ! 268 !> Detects areas to be refined. 269 !--------------------------------------------------------------------------------------------------- 270 recursive subroutine Agrif_detect_all ( g ) 271 !--------------------------------------------------------------------------------------------------- 272 TYPE(Agrif_Grid), pointer :: g !< Pointer on the current grid 273 ! 274 Type(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive procedure 275 integer, DIMENSION(3) :: size 276 integer :: i 277 real :: g_eps 278 ! 279 parcours => g % child_list % first 280 ! 281 ! To be positioned on the finer grids of the grid hierarchy 282 ! 283 do while (associated(parcours)) 284 call Agrif_detect_all(parcours % gr) 285 parcours => parcours % next 286 enddo 287 ! 288 g_eps = huge(1.) 289 do i = 1,Agrif_Probdim 290 g_eps = min(g_eps, g % Agrif_dx(i)) 291 enddo 292 ! 293 g_eps = g_eps / 100. 294 ! 295 if ( Agrif_Probdim == 1 ) g%tabpoint1D = 0 296 if ( Agrif_Probdim == 2 ) g%tabpoint2D = 0 297 if ( Agrif_Probdim == 3 ) g%tabpoint3D = 0 298 ! 299 do i = 1,Agrif_Probdim 300 if ( g%Agrif_dx(i)/Agrif_coeffref(i) < (Agrif_mind(i)-g_eps) ) return 301 enddo 302 ! 303 call Agrif_instance(g) 304 ! 305 ! Detection (Agrif_detect is a users routine) 306 ! 307 do i = 1,Agrif_Probdim 308 size(i) = g % nb(i) + 1 309 enddo 310 ! 311 SELECT CASE (Agrif_Probdim) 312 CASE (1) 313 call Agrif_detect(g%tabpoint1D,size) 314 CASE (2) 315 call Agrif_detect(g%tabpoint2D,size) 316 CASE (3) 317 call Agrif_detect(g%tabpoint3D,size) 318 END SELECT 319 ! 320 ! Addition of the areas detected on the child grids 321 ! 322 parcours => g % child_list % first 323 ! 324 do while (associated(parcours)) 325 call Agrif_Add_detected_areas(g,parcours % gr) 326 parcours => parcours % next 327 enddo 328 !--------------------------------------------------------------------------------------------------- 329 end subroutine Agrif_detect_all 330 !=================================================================================================== 331 ! 332 !=================================================================================================== 333 ! subroutine Agrif_Add_detected_areas 334 ! 335 !> Adds on the parent grid the areas detected on its child grids 336 !--------------------------------------------------------------------------------------------------- 337 subroutine Agrif_Add_detected_areas ( parentgrid, childgrid ) 338 !--------------------------------------------------------------------------------------------------- 339 Type(Agrif_Grid), pointer :: parentgrid 340 Type(Agrif_Grid), pointer :: childgrid 341 ! 342 integer :: i,j,k 343 ! 344 do i = 1,childgrid%nb(1)+1 345 if ( Agrif_Probdim == 1 ) then 346 if (childgrid%tabpoint1D(i)==1) then 347 parentgrid%tabpoint1D(childgrid%ix(1)+(i-1)/Agrif_Coeffref(1)) = 1 348 endif 349 else 350 do j=1,childgrid%nb(2)+1 351 if (Agrif_Probdim==2) then 352 if (childgrid%tabpoint2D(i,j)==1) then 353 parentgrid%tabpoint2D( & 354 childgrid%ix(1)+(i-1)/Agrif_Coeffref(1), & 355 childgrid%ix(2)+(j-1)/Agrif_Coeffref(2)) = 1 356 endif 357 else 358 do k=1,childgrid%nb(3)+1 359 if (childgrid%tabpoint3D(i,j,k)==1) then 360 parentgrid%tabpoint3D( & 361 childgrid%ix(1)+(i-1)/Agrif_Coeffref(1), & 362 childgrid%ix(2)+(j-1)/Agrif_Coeffref(2), & 363 childgrid%ix(3)+(k-1)/Agrif_Coeffref(3)) = 1 364 endif 365 enddo 366 endif 367 enddo 368 endif 369 enddo 370 !--------------------------------------------------------------------------------------------------- 371 end subroutine Agrif_Add_detected_areas 372 !=================================================================================================== 373 ! 374 !=================================================================================================== 375 ! subroutine Agrif_Free_before_All 376 !--------------------------------------------------------------------------------------------------- 377 recursive subroutine Agrif_Free_before_All ( gridlist ) 378 !--------------------------------------------------------------------------------------------------- 379 Type(Agrif_Grid_List), intent(inout) :: gridlist !< Grid list 380 ! 381 Type(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive procedure 382 ! 383 parcours => gridlist % first 384 ! 385 do while (associated(parcours)) 386 ! 387 if (.not. parcours%gr%fixed) then 388 call Agrif_Free_data_before(parcours%gr) 389 parcours % gr % oldgrid = .TRUE. 390 endif 391 ! 392 call Agrif_Free_before_all (parcours % gr % child_list) 393 ! 394 parcours => parcours % next 395 ! 396 enddo 397 !--------------------------------------------------------------------------------------------------- 398 end subroutine Agrif_Free_before_All 399 !=================================================================================================== 400 ! 401 !=================================================================================================== 402 ! subroutine Agrif_Save_All 403 !--------------------------------------------------------------------------------------------------- 404 recursive subroutine Agrif_Save_All ( gridlist ) 405 !--------------------------------------------------------------------------------------------------- 406 type(Agrif_Grid_List), intent(inout) :: gridlist !< Grid list 407 ! 408 type(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive procedure 409 ! 410 parcours => gridlist % first 411 ! 412 do while (associated(parcours)) 413 ! 414 if (.not. parcours%gr%fixed) then 415 call Agrif_Instance(parcours%gr) 416 call Agrif_Before_Regridding() 417 parcours % gr % oldgrid = .TRUE. 418 endif 419 ! 420 call Agrif_Save_All(parcours % gr % child_list) 421 ! 422 parcours => parcours % next 423 ! 424 enddo 425 !--------------------------------------------------------------------------------------------------- 426 end subroutine Agrif_Save_All 427 !=================================================================================================== 428 ! 429 !=================================================================================================== 430 ! subroutine Agrif_Free_after_All 431 !--------------------------------------------------------------------------------------------------- 432 recursive subroutine Agrif_Free_after_All ( gridlist ) 433 !--------------------------------------------------------------------------------------------------- 434 Type(Agrif_Grid_List), intent(inout) :: gridlist !< Grid list to free 435 ! 436 Type(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive proced 437 Type(Agrif_PGrid), pointer :: preparcours 438 Type(Agrif_PGrid), pointer :: preparcoursini 439 ! 440 allocate(preparcours) 441 ! 442 preparcoursini => preparcours 443 ! 444 nullify(preparcours % gr) 445 ! 446 preparcours % next => gridlist % first 447 parcours => gridlist % first 448 ! 449 do while (associated(parcours)) 450 ! 451 if ( (.NOT. parcours%gr % fixed) .AND. (parcours%gr % oldgrid) ) then 452 call Agrif_Free_data_after(parcours%gr) 453 endif 454 ! 455 call Agrif_Free_after_all( parcours%gr % child_list ) 456 ! 457 if (parcours % gr % oldgrid) then 458 deallocate(parcours % gr) 459 preparcours % next => parcours % next 460 deallocate(parcours) 461 parcours => preparcours % next 462 else 463 preparcours => preparcours % next 464 parcours => parcours % next 465 endif 466 ! 467 enddo 468 ! 469 deallocate(preparcoursini) 470 !--------------------------------------------------------------------------------------------------- 471 end subroutine Agrif_Free_after_All 472 !=================================================================================================== 473 ! 474 !=================================================================================================== 475 ! subroutine Agrif_Integrate 476 ! 477 !> Manages the time integration of the grid hierarchy. 478 !! Recursive subroutine and call on subroutines Agrif_Init::Agrif_Instance and #Agrif_Step 479 !--------------------------------------------------------------------------------------------------- 480 recursive subroutine Agrif_Integrate ( g, procname ) 481 !--------------------------------------------------------------------------------------------------- 482 type(Agrif_Grid), pointer :: g !< Pointer on the current grid 483 procedure(step_proc) :: procname !< Subroutine to call on each grid 484 ! 485 type(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive procedure 486 integer :: nbt ! Number of time steps of the current grid 487 integer :: i, k 488 ! 489 ! Instanciation of the variables of the current grid 490 ! if ( g % fixedrank /= 0 ) then 491 call Agrif_Instance(g) 492 ! endif 493 ! 494 ! One step on the current grid 495 ! 496 call procname () 497 ! 498 ! Number of time steps on the current grid 499 ! 500 g%ngridstep = g % ngridstep + 1 501 parcours => g % child_list % first 502 ! 503 ! Recursive procedure for the time integration of the grid hierarchy 504 do while (associated(parcours)) 505 ! 506 ! Instanciation of the variables of the current grid 507 call Agrif_Instance(parcours % gr) 508 ! 509 ! Number of time steps 510 nbt = 1 511 do i = 1,Agrif_Probdim 512 nbt = max(nbt, parcours % gr % timeref(i)) 513 enddo 514 ! 515 do k = 1,nbt 516 call Agrif_Integrate(parcours % gr, procname) 517 enddo 518 ! 519 parcours => parcours % next 520 ! 521 enddo 522 !--------------------------------------------------------------------------------------------------- 523 end subroutine Agrif_Integrate 524 !=================================================================================================== 525 ! 526 !=================================================================================================== 527 ! subroutine Agrif_Integrate_Parallel 528 ! 529 !> Manages the time integration of the grid hierarchy in parallel 530 !! Recursive subroutine and call on subroutines Agrif_Init::Agrif_Instance and #Agrif_Step 531 !--------------------------------------------------------------------------------------------------- 532 recursive subroutine Agrif_Integrate_Parallel ( g, procname ) 533 !--------------------------------------------------------------------------------------------------- 534 type(Agrif_Grid), pointer :: g !< Pointer on the current grid 535 procedure(step_proc) :: procname !< Subroutine to call on each grid 536 ! 537 #if defined AGRIF_MPI 538 type(Agrif_PGrid), pointer :: gridp ! Pointer for the recursive procedure 539 integer :: nbt ! Number of time steps of the current grid 540 integer :: i, k, is 541 ! 542 ! Instanciation of the variables of the current grid 543 if ( g % fixedrank /= 0 ) then 544 call Agrif_Instance(g) 545 endif 546 ! 547 ! One step on the current grid 548 call procname () 549 ! 550 ! Number of time steps on the current grid 551 g % ngridstep = g % ngridstep + 1 552 ! 553 ! Continue only if the grid has defined sequences of child integrations. 554 if ( .not. associated(g % child_seq) ) return 555 ! 556 do is = 1, g % child_seq % nb_seqs 557 ! 558 ! For each sequence, a given processor does integrate only on grid. 559 gridp => Agrif_seq_select_child(g,is) 560 ! 561 ! Instanciation of the variables of the current grid 562 call Agrif_Instance(gridp % gr) 563 ! 564 ! Number of time steps 565 nbt = 1 566 do i = 1,Agrif_Probdim 567 nbt = max(nbt, gridp % gr % timeref(i)) 568 enddo 569 ! 570 do k = 1,nbt 571 call Agrif_Integrate_Parallel(gridp % gr, procname) 572 enddo 573 ! 574 enddo 575 #else 576 call Agrif_Integrate( g, procname ) 577 #endif 578 !--------------------------------------------------------------------------------------------------- 579 end subroutine Agrif_Integrate_Parallel 580 !=================================================================================================== 581 ! 582 !=================================================================================================== 583 ! 584 ! 585 !=================================================================================================== 586 ! subroutine Agrif_Integrate_ChildGrids 587 ! 588 !> Manages the time integration of the grid hierarchy. 589 !! Call the subroutine procname on each child grid of the current grid 590 !--------------------------------------------------------------------------------------------------- 591 recursive subroutine Agrif_Integrate_ChildGrids ( procname ) 592 !--------------------------------------------------------------------------------------------------- 593 procedure(step_proc) :: procname !< Subroutine to call on each grid 594 ! 595 type(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive procedure 596 integer :: nbt ! Number of time steps of the current grid 597 integer :: i, k, is 598 type(Agrif_Grid) , pointer :: save_grid 599 type(Agrif_PGrid), pointer :: gridp ! Pointer for the recursive procedure 600 601 save_grid => Agrif_Curgrid 602 603 ! Number of time steps on the current grid 604 save_grid % ngridstep = save_grid % ngridstep + 1 605 606 #ifdef AGRIF_MPI 607 if ( .not. Agrif_Parallel_sisters ) then 608 #endif 609 parcours => save_grid % child_list % first 610 ! 611 ! Recursive procedure for the time integration of the grid hierarchy 612 do while (associated(parcours)) 613 ! 614 ! Instanciation of the variables of the current grid 615 call Agrif_Instance(parcours % gr) 616 ! 617 ! Number of time steps 618 nbt = 1 619 do i = 1,Agrif_Probdim 620 nbt = max(nbt, parcours % gr % timeref(i)) 621 enddo 622 ! 623 do k = 1,nbt 624 call procname() 625 enddo 626 ! 627 parcours => parcours % next 628 ! 629 enddo 630 631 #ifdef AGRIF_MPI 632 else 633 ! Continue only if the grid has defined sequences of child integrations. 634 if ( .not. associated(save_grid % child_seq) ) return 635 ! 636 do is = 1, save_grid % child_seq % nb_seqs 637 ! 638 ! For each sequence, a given processor does integrate only on grid. 639 gridp => Agrif_seq_select_child(save_grid,is) 640 ! 641 ! Instanciation of the variables of the current grid 642 call Agrif_Instance(gridp % gr) 643 ! 644 ! Number of time steps 645 nbt = 1 646 do i = 1,Agrif_Probdim 647 nbt = max(nbt, gridp % gr % timeref(i)) 648 enddo 649 ! 650 do k = 1,nbt 651 call procname() 652 enddo 653 ! 654 enddo 655 endif 656 #endif 657 658 call Agrif_Instance(save_grid) 659 660 !--------------------------------------------------------------------------------------------------- 661 end subroutine Agrif_Integrate_ChildGrids 662 !=================================================================================================== 663 !=================================================================================================== 664 ! subroutine Agrif_Integrate_Child 665 ! 666 !> Manages the time integration of the grid hierarchy. 667 !! Recursive subroutine and call on subroutines Agrif_Instance & Agrif_Step. 668 !--------------------------------------------------------------------------------------------------- 669 recursive subroutine Agrif_Integrate_Child ( g, procname ) 670 !--------------------------------------------------------------------------------------------------- 671 type(Agrif_Grid), pointer :: g !< Pointer on the current grid 672 procedure(step_proc) :: procname !< Subroutine to call on each grid 673 ! 674 type(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive procedure 675 ! 676 ! One step on the current grid 677 ! 678 call procname () 679 ! 680 ! Number of time steps on the current grid 681 ! 682 parcours => g % child_list % first 683 ! 684 ! Recursive procedure for the time integration of the grid hierarchy 685 do while (associated(parcours)) 686 ! 687 ! Instanciation of the variables of the current grid 688 call Agrif_Instance(parcours % gr) 689 call Agrif_Integrate_Child (parcours % gr, procname) 690 parcours => parcours % next 691 ! 692 enddo 693 !--------------------------------------------------------------------------------------------------- 694 end subroutine Agrif_Integrate_Child 695 !=================================================================================================== 696 ! 697 !=================================================================================================== 698 ! subroutine Agrif_Integrate_Child_Parallel 699 ! 700 !> Manages the time integration of the grid hierarchy. 701 !! Recursive subroutine and call on subroutines Agrif_Instance & Agrif_Step. 702 !--------------------------------------------------------------------------------------------------- 703 recursive subroutine Agrif_Integrate_Child_Parallel ( g, procname ) 704 !--------------------------------------------------------------------------------------------------- 705 type(Agrif_Grid), pointer :: g !< Pointer on the current grid 706 procedure(step_proc) :: procname !< Subroutine to call on each grid 707 ! 708 #if defined AGRIF_MPI 709 type(Agrif_PGrid), pointer :: gridp ! Pointer for the recursive procedure 710 integer :: is 711 ! 712 ! Instanciation of the variables of the current grid 713 call Agrif_Instance(g) 714 ! 715 ! One step on the current grid 716 call procname () 717 ! 718 ! Continue only if the grid has defined sequences of child integrations. 719 if ( .not. associated(g % child_seq) ) return 720 ! 721 do is = 1, g % child_seq % nb_seqs 722 ! 723 ! For each sequence, a given processor does integrate only on grid. 724 gridp => Agrif_seq_select_child(g,is) 725 call Agrif_Integrate_Child_Parallel(gridp % gr, procname) 726 ! 727 enddo 728 ! 729 call Agrif_Instance(g) 730 #else 731 call Agrif_Integrate_Child( g, procname ) 732 #endif 733 !--------------------------------------------------------------------------------------------------- 734 end subroutine Agrif_Integrate_Child_Parallel 735 !=================================================================================================== 736 ! 737 !=================================================================================================== 738 ! subroutine Agrif_Init_Grids 739 ! 740 !> Initializes the root coarse grid pointed by Agrif_Mygrid. It is called in the main program. 741 !--------------------------------------------------------------------------------------------------- 742 subroutine Agrif_Init_Grids ( procname1, procname2 ) 743 !--------------------------------------------------------------------------------------------------- 744 procedure(typedef_proc), optional :: procname1 !< (Default: Agrif_probdim_modtype_def) 745 procedure(alloc_proc), optional :: procname2 !< (Default: Agrif_Allocationcalls) 746 ! 747 integer :: i, ierr_allocate, nunit 748 integer :: is_coarse, rhox,rhoy,rhoz,rhot 749 logical :: BEXIST 750 ! 751 if (present(procname1)) Then 752 call procname1() 753 else 754 call Agrif_probdim_modtype_def() 755 endif 756 ! 757 758 ! TEST FOR COARSE GRID (GRAND MOTHER GRID) in AGRIF_FixedGrids.in 759 nunit = Agrif_Get_Unit() 760 open(nunit, file='AGRIF_FixedGrids.in', form='formatted', status="old", ERR=98) 761 if (Agrif_Probdim == 3) then 762 read(nunit,*) is_coarse, rhox, rhoy, rhoz, rhot 763 elseif (Agrif_Probdim == 2) then 764 read(nunit,*) is_coarse, rhox, rhoy, rhot 765 elseif (Agrif_Probdim == 2) then 766 read(nunit,*) is_coarse, rhox, rhot 767 endif 768 if (is_coarse == -1) then 769 agrif_coarse = .TRUE. 770 if (Agrif_Probdim == 3) then 771 coarse_spaceref(1:3)=(/rhox,rhoy,rhoz/) 772 elseif (Agrif_Probdim == 2) then 773 coarse_spaceref(1:2)=(/rhox,rhoy/) 774 elseif (Agrif_Probdim == 2) then 775 coarse_spaceref(1:1)=(/rhox/) 776 endif 777 coarse_timeref(1:Agrif_Probdim) = rhot 778 endif 779 close(nunit) 780 781 Agrif_UseSpecialValue = .FALSE. 782 Agrif_UseSpecialValueFineGrid = .FALSE. 783 Agrif_SpecialValue = 0. 784 Agrif_SpecialValueFineGrid = 0. 785 ! 786 allocate(Agrif_Mygrid) 787 allocate(Agrif_OldMygrid) 788 ! 789 ! Space and time refinement factors are set to 1 on the root grid 790 ! 791 do i = 1,Agrif_Probdim 792 Agrif_Mygrid % spaceref(i) = coarse_spaceref(i) 793 Agrif_Mygrid % timeref(i) = coarse_timeref(i) 794 enddo 795 ! 796 ! Initialization of the number of time steps 797 Agrif_Mygrid % ngridstep = 0 798 Agrif_Mygrid % grid_id = 0 799 ! 800 ! No parent grid for the root coarse grid 801 nullify(Agrif_Mygrid % parent) 802 ! 803 ! Initialization of the minimum positions, global abscissa and space steps 804 do i = 1, Agrif_Probdim 805 Agrif_Mygrid % ix(i) = 1 806 Agrif_Mygrid % Agrif_x(i) = 0. 807 Agrif_Mygrid % Agrif_dx(i) = 1./Agrif_Mygrid % spaceref(i) 808 Agrif_Mygrid % Agrif_dt(i) = 1./Agrif_Mygrid % timeref(i) 809 ! Borders of the root coarse grid 810 Agrif_Mygrid % NearRootBorder(i) = .true. 811 Agrif_Mygrid % DistantRootBorder(i) = .true. 812 enddo 813 ! 814 ! The root coarse grid is a fixed grid 815 Agrif_Mygrid % fixed = .TRUE. 816 ! Level of the root grid 817 Agrif_Mygrid % level = 0 818 ! Maximum level in the hierarchy 819 Agrif_MaxLevelLoc = 0 820 ! 821 ! Number of the grid pointed by Agrif_Mygrid (root coarse grid) 822 Agrif_Mygrid % rank = 1 823 ! 824 ! Number of the root grid as a fixed grid 825 Agrif_Mygrid % fixedrank = 0 826 ! 827 ! Initialization of some fields of the root grid variables 828 ierr_allocate = 0 829 if( Agrif_NbVariables(0) > 0 ) allocate(Agrif_Mygrid % tabvars(Agrif_NbVariables(0)),stat=ierr_allocate) 830 if( Agrif_NbVariables(1) > 0 ) allocate(Agrif_Mygrid % tabvars_c(Agrif_NbVariables(1)),stat=ierr_allocate) 831 if( Agrif_NbVariables(2) > 0 ) allocate(Agrif_Mygrid % tabvars_r(Agrif_NbVariables(2)),stat=ierr_allocate) 832 if( Agrif_NbVariables(3) > 0 ) allocate(Agrif_Mygrid % tabvars_l(Agrif_NbVariables(3)),stat=ierr_allocate) 833 if( Agrif_NbVariables(4) > 0 ) allocate(Agrif_Mygrid % tabvars_i(Agrif_NbVariables(4)),stat=ierr_allocate) 834 if (ierr_allocate /= 0) THEN 835 STOP "*** ERROR WHEN ALLOCATING TABVARS ***" 836 endif 837 ! 838 ! Initialization of the other fields of the root grid variables (number of 839 ! cells, positions, number and type of its dimensions, ...) 840 call Agrif_Instance(Agrif_Mygrid) 841 call Agrif_Set_numberofcells(Agrif_Mygrid) 842 ! 843 ! Allocation of the array containing the values of the grid variables 844 call Agrif_Allocation(Agrif_Mygrid, procname2) 845 call Agrif_initialisations(Agrif_Mygrid) 846 ! 847 ! Total number of fixed grids 848 Agrif_nbfixedgrids = 0 849 850 ! If a grand mother grid is declared 851 852 if (agrif_coarse) then 853 allocate(Agrif_Coarsegrid) 854 855 Agrif_Coarsegrid % ngridstep = 0 856 Agrif_Coarsegrid % grid_id = -9999 857 858 do i = 1, Agrif_Probdim 859 Agrif_Coarsegrid%spaceref(i) = coarse_spaceref(i) 860 Agrif_Coarsegrid%timeref(i) = coarse_timeref(i) 861 Agrif_Coarsegrid % ix(i) = 1 862 Agrif_Coarsegrid % Agrif_x(i) = 0. 863 Agrif_Coarsegrid % Agrif_dx(i) = 1. 864 Agrif_Coarsegrid % Agrif_dt(i) = 1. 865 ! Borders of the root coarse grid 866 Agrif_Coarsegrid % NearRootBorder(i) = .true. 867 Agrif_Coarsegrid % DistantRootBorder(i) = .true. 868 Agrif_Coarsegrid % nb(i) =Agrif_mygrid%nb(i) / coarse_spaceref(i) 869 enddo 870 871 ! The root coarse grid is a fixed grid 872 Agrif_Coarsegrid % fixed = .TRUE. 873 ! Level of the root grid 874 Agrif_Coarsegrid % level = -1 875 876 Agrif_Coarsegrid % grand_mother_grid = .true. 877 878 ! Number of the grid pointed by Agrif_Mygrid (root coarse grid) 879 Agrif_Coarsegrid % rank = -9999 880 ! 881 ! Number of the root grid as a fixed grid 882 Agrif_Coarsegrid % fixedrank = -9999 883 884 Agrif_Mygrid%parent => Agrif_Coarsegrid 885 886 ! Not used but required to prevent seg fault 887 Agrif_Coarsegrid%parent => Agrif_Mygrid 888 889 call Agrif_Create_Var(Agrif_Coarsegrid) 890 891 ! Reset to null 892 Nullify(Agrif_Coarsegrid%parent) 893 894 Agrif_Coarsegrid%child_list%nitems = 1 895 allocate(Agrif_Coarsegrid%child_list%first) 896 allocate(Agrif_Coarsegrid%child_list%last) 897 Agrif_Coarsegrid%child_list%first%gr => Agrif_Mygrid 898 Agrif_Coarsegrid%child_list%last%gr => Agrif_Mygrid 899 900 endif 901 902 return 903 904 98 INQUIRE(FILE='AGRIF_FixedGrids.in',EXIST=BEXIST) 905 if (.not. BEXIST) then 906 print*,'ERROR : File AGRIF_FixedGrids.in not found.' 907 STOP 908 else 909 print*,'Error opening file AGRIF_FixedGrids.in' 910 STOP 911 endif 912 913 !--------------------------------------------------------------------------------------------------- 914 end subroutine Agrif_Init_Grids 915 !=================================================================================================== 916 ! 917 !=================================================================================================== 918 ! subroutine Agrif_Deallocation 919 ! 920 !> Deallocates all data arrays. 921 !--------------------------------------------------------------------------------------------------- 922 subroutine Agrif_Deallocation 923 !--------------------------------------------------------------------------------------------------- 924 integer :: nb 925 type(Agrif_Variable), pointer :: var 926 type(Agrif_Variable_c), pointer :: var_c 927 type(Agrif_Variable_l), pointer :: var_l 928 type(Agrif_Variable_i), pointer :: var_i 929 ! 930 do nb = 1,Agrif_NbVariables(0) 931 ! 932 var => Agrif_Mygrid % tabvars(nb) 933 ! 934 if ( allocated(var % array1) ) deallocate(var % array1) 935 if ( allocated(var % array2) ) deallocate(var % array2) 936 if ( allocated(var % array3) ) deallocate(var % array3) 937 if ( allocated(var % array4) ) deallocate(var % array4) 938 if ( allocated(var % array5) ) deallocate(var % array5) 939 if ( allocated(var % array6) ) deallocate(var % array6) 940 ! 941 if ( allocated(var % sarray1) ) deallocate(var % sarray1) 942 if ( allocated(var % sarray2) ) deallocate(var % sarray2) 943 if ( allocated(var % sarray3) ) deallocate(var % sarray3) 944 if ( allocated(var % sarray4) ) deallocate(var % sarray4) 945 if ( allocated(var % sarray5) ) deallocate(var % sarray5) 946 if ( allocated(var % sarray6) ) deallocate(var % sarray6) 947 ! 948 if ( allocated(var % darray1) ) deallocate(var % darray1) 949 if ( allocated(var % darray2) ) deallocate(var % darray2) 950 if ( allocated(var % darray3) ) deallocate(var % darray3) 951 if ( allocated(var % darray4) ) deallocate(var % darray4) 952 if ( allocated(var % darray5) ) deallocate(var % darray5) 953 if ( allocated(var % darray6) ) deallocate(var % darray6) 954 ! 955 enddo 956 ! 957 do nb = 1,Agrif_NbVariables(1) 958 ! 959 var_c => Agrif_Mygrid % tabvars_c(nb) 960 ! 961 if ( allocated(var_c % carray1) ) deallocate(var_c % carray1) 962 if ( allocated(var_c % carray2) ) deallocate(var_c % carray2) 963 ! 964 enddo 965 966 do nb = 1,Agrif_NbVariables(3) 967 ! 968 var_l => Agrif_Mygrid % tabvars_l(nb) 969 ! 970 if ( allocated(var_l % larray1) ) deallocate(var_l % larray1) 971 if ( allocated(var_l % larray2) ) deallocate(var_l % larray2) 972 if ( allocated(var_l % larray3) ) deallocate(var_l % larray3) 973 if ( allocated(var_l % larray4) ) deallocate(var_l % larray4) 974 if ( allocated(var_l % larray5) ) deallocate(var_l % larray5) 975 if ( allocated(var_l % larray6) ) deallocate(var_l % larray6) 976 ! 977 enddo 978 ! 979 do nb = 1,Agrif_NbVariables(4) 980 ! 981 var_i => Agrif_Mygrid % tabvars_i(nb) 982 ! 983 if ( allocated(var_i % iarray1) ) deallocate(var_i % iarray1) 984 if ( allocated(var_i % iarray2) ) deallocate(var_i % iarray2) 985 if ( allocated(var_i % iarray3) ) deallocate(var_i % iarray3) 986 if ( allocated(var_i % iarray4) ) deallocate(var_i % iarray4) 987 if ( allocated(var_i % iarray5) ) deallocate(var_i % iarray5) 988 if ( allocated(var_i % iarray6) ) deallocate(var_i % iarray6)