Changeset 10087 for vendors/AGRIF/CMEMS_2020
- Timestamp:
- 2018-09-05T15:33:44+02:00 (6 years ago)
- Location:
- vendors/AGRIF/CMEMS_2020/AGRIF_FILES
- Files:
-
- 6 added
- 19 edited
Legend:
- Unmodified
- Added
- Removed
-
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modarrays.F90
r5656 r10087 55 55 proc_id, & 56 56 coords, & 57 lb_tab_true, ub_tab_true, memberin ) 57 lb_tab_true, ub_tab_true, memberin, & 58 indminglob3,indmaxglob3) 58 59 !--------------------------------------------------------------------------------------------------- 59 60 integer, intent(in) :: nbdim !< Number of dimensions … … 61 62 integer, dimension(nbdim), intent(in) :: ub_var !< Local upper boundary on the current processor 62 63 integer, dimension(nbdim), intent(in) :: lb_tab !< Global lower boundary of the variable 64 integer, dimension(nbdim),OPTIONAL :: indminglob3,indmaxglob3 !< True bounds for MPI USE 63 65 integer, dimension(nbdim), intent(in) :: ub_tab !< Global upper boundary of the variable 64 66 integer, intent(in) :: proc_id !< Current processor … … 78 80 call Agrif_InvLoc( lb_var(i), proc_id, coord_i, lb_glob_index ) 79 81 call Agrif_InvLoc( ub_var(i), proc_id, coord_i, ub_glob_index ) 82 if (present(indminglob3)) then 83 indminglob3(i)=lb_glob_index 84 indmaxglob3(i)=ub_glob_index 85 endif 80 86 #else 81 87 lb_glob_index = lb_var(i) 82 88 ub_glob_index = ub_var(i) 83 89 #endif 90 84 91 lb_tab_true(i) = max(lb_tab(i), lb_glob_index) 85 92 ub_tab_true(i) = min(ub_tab(i), ub_glob_index) 93 86 94 enddo 87 95 ! … … 123 131 ! 124 132 iminmaxg(1:nbdim,2) = - iminmaxg(1:nbdim,2) 125 call MPI_ALLREDUCE(iminmaxg, lubglob, 2*nbdim, MPI_INTEGER, MPI_MIN, Agrif_mpi_comm, code) 133 call MPI_ALLREDUCE(iminmaxg, lubglob, 2*nbdim, MPI_INTEGER, MPI_MIN, & 134 Agrif_mpi_comm, code) 126 135 lubglob(1:nbdim,2) = - lubglob(1:nbdim,2) 127 136 #endif … … 225 234 case (1) ; call Agrif_set_array_tozero_1D(variable%array1) 226 235 case (2) ; call Agrif_set_array_tozero_2D(variable%array2) 227 case (3) ; call Agrif_set_array_tozero_3D(variable%array3) 236 case (3) ; call Agrif_set_array_tozero_reshape(variable%array3,size(variable%array3)) 237 !case (3) ; call Agrif_set_array_tozero_3D(variable%array3) 228 238 case (4) ; call Agrif_set_array_tozero_4D(variable%array4) 229 239 case (5) ; call Agrif_set_array_tozero_5D(variable%array5) … … 266 276 !=================================================================================================== 267 277 ! 278 !=================================================================================================== 279 ! 280 !=================================================================================================== 281 ! subroutine agrif_set_array_cond 282 ! 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 !< Variablein 288 type(Agrif_Variable), intent(inout) :: variableout !< Variableout 289 real,intent(in) :: value !< special value 290 integer, intent(in) :: nbdim !< Dimension of the array 291 292 ! 293 select case (nbdim) 294 case (1) ; call agrif_set_array_cond_1D(variablein%array1,variableout%array1,value) 295 case (2) ; call agrif_set_array_cond_2D(variablein%array2,variableout%array2,value) 296 case (3) ; call agrif_set_array_cond_reshape(variablein%array3,variableout%array3,value,size(variablein%array3)) 297 ! case (3) ; call agrif_set_array_cond_3D(variablein%array3,variableout%array3,value) 298 case (4) ; call agrif_set_array_cond_4D(variablein%array4,variableout%array4,value) 299 case (5) ; call agrif_set_array_cond_5D(variablein%array5,variableout%array5,value) 300 case (6) ; call agrif_set_array_cond_6D(variablein%array6,variableout%array6,value) 301 end select 302 !--------------------------------------------------------------------------------------------------- 303 contains 304 !--------------------------------------------------------------------------------------------------- 305 subroutine agrif_set_array_cond_1D(arrayin,arrayout,value) 306 real,dimension(:),intent(in) :: arrayin 307 real,dimension(:),intent(out) :: arrayout 308 real :: value 309 310 where (arrayin == value) 311 arrayout = 0. 312 elsewhere 313 arrayout = 1. 314 end where 315 316 end subroutine agrif_set_array_cond_1D 317 ! 318 subroutine agrif_set_array_cond_2D(arrayin,arrayout,value) 319 real,dimension(:,:),intent(in) :: arrayin 320 real,dimension(:,:),intent(out) :: arrayout 321 real :: value 322 323 where (arrayin == value) 324 arrayout = 0. 325 elsewhere 326 arrayout = 1. 327 end where 328 329 end subroutine agrif_set_array_cond_2D 330 ! 331 subroutine agrif_set_array_cond_3D(arrayin,arrayout,value) 332 real,dimension(:,:,:),intent(in) :: arrayin 333 real,dimension(:,:,:),intent(out) :: arrayout 334 real :: value 335 336 where (arrayin == value) 337 arrayout = 0. 338 elsewhere 339 arrayout = 1. 340 end where 341 342 end subroutine agrif_set_array_cond_3D 343 ! 344 subroutine agrif_set_array_cond_4D(arrayin,arrayout,value) 345 real,dimension(:,:,:,:),intent(in) :: arrayin 346 real,dimension(:,:,:,:),intent(out) :: arrayout 347 real :: value 348 349 where (arrayin == value) 350 arrayout = 0. 351 elsewhere 352 arrayout = 1. 353 end where 354 355 end subroutine agrif_set_array_cond_4D 356 ! 357 subroutine agrif_set_array_cond_5D(arrayin,arrayout,value) 358 real,dimension(:,:,:,:,:),intent(in) :: arrayin 359 real,dimension(:,:,:,:,:),intent(out) :: arrayout 360 real :: value 361 362 where (arrayin == value) 363 arrayout = 0. 364 elsewhere 365 arrayout = 1. 366 end where 367 368 end subroutine agrif_set_array_cond_5D 369 ! 370 subroutine agrif_set_array_cond_6D(arrayin,arrayout,value) 371 real,dimension(:,:,:,:,:,:),intent(in) :: arrayin 372 real,dimension(:,:,:,:,:,:),intent(out) :: arrayout 373 real :: value 374 375 where (arrayin == value) 376 arrayout = 0. 377 elsewhere 378 arrayout = 1. 379 end where 380 381 end subroutine agrif_set_array_cond_6D 382 !--------------------------------------------------------------------------------------------------- 383 end subroutine agrif_set_array_cond 268 384 !=================================================================================================== 269 385 ! subroutine Agrif_var_copy_array … … 330 446 real, dimension(l(1):,l(2):,l(3):), intent(out) :: tabout 331 447 real, dimension(m(1):,m(2):,m(3):), intent(in) :: tabin 332 tabout(inf1(1):sup1(1), & 333 inf1(2):sup1(2), & 334 inf1(3):sup1(3)) = tabin(inf2(1):sup2(1), & 335 inf2(2):sup2(2), & 336 inf2(3):sup2(3)) 448 integer :: i,j,k 449 450 451 !$OMP PARALLEL DO DEFAULT(none) PRIVATE(i,j,k) & 452 !$OMP SHARED(inf1,inf2,sup1,sup2,tabin,tabout) & 453 !$OMP SCHEDULE(RUNTIME) 454 do k=inf1(3),sup1(3) 455 do j=inf1(2),sup1(2) 456 do i=inf1(1),sup1(1) 457 ! tabout(i,j,k) = tabin(i+inf2(1)-inf1(1),j+inf2(2)-inf1(2),k+inf2(3)-inf1(3)) 458 tabout(i,j,k) = tabin(i,j,k) 459 enddo 460 enddo 461 enddo 462 !$OMP END PARALLEL DO 463 464 465 ! tabout(inf1(1):sup1(1), & 466 ! inf1(2):sup1(2), & 467 ! inf1(3):sup1(3)) = tabin(inf2(1):sup2(1), & 468 ! inf2(2):sup2(2), & 469 ! inf2(3):sup2(3)) 337 470 end subroutine Agrif_copy_array_3d 338 471 ! … … 631 764 integer, dimension(6), intent(out) :: lb_child !< Lower bound on the child grid 632 765 integer, dimension(6), intent(out) :: lb_parent !< Lower bound on the parent grid 633 real , dimension(6), intent(out):: s_child !< Child grid position (s_root = 0)634 real , dimension(6), intent(out):: s_parent !< Parent grid position (s_root = 0)635 real , dimension(6), intent(out):: ds_child !< Child grid dx (ds_root = 1)636 real , dimension(6), intent(out):: ds_parent !< Parent grid dx (ds_root = 1)766 real(kind=8), dimension(6), intent(out) :: s_child !< Child grid position (s_root = 0) 767 real(kind=8), dimension(6), intent(out) :: s_parent !< Parent grid position (s_root = 0) 768 real(kind=8), dimension(6), intent(out) :: ds_child !< Child grid dx (ds_root = 1) 769 real(kind=8), dimension(6), intent(out) :: ds_parent !< Parent grid dx (ds_root = 1) 637 770 integer, intent(out) :: nbdim !< Number of dimensions 638 771 logical, intent(in) :: interp !< .true. if preprocess for interpolation, \n … … 671 804 else 672 805 ub_child(n) = lb_child(n) + Agrif_Child_Gr % nb(1) - 1 673 s_child(n) = s_child(n) + 0.5 *ds_child(n)674 s_parent(n) = s_parent(n) + 0.5 *ds_parent(n)806 s_child(n) = s_child(n) + 0.5d0*ds_child(n) 807 s_parent(n) = s_parent(n) + 0.5d0*ds_parent(n) 675 808 endif 676 809 ! … … 689 822 else 690 823 ub_child(n) = lb_child(n) + Agrif_Child_Gr % nb(2) - 1 691 s_child(n) = s_child(n) + 0.5 *ds_child(n)692 s_parent(n) = s_parent(n) + 0.5 *ds_parent(n)824 s_child(n) = s_child(n) + 0.5d0*ds_child(n) 825 s_parent(n) = s_parent(n) + 0.5d0*ds_parent(n) 693 826 endif 694 827 ! … … 727 860 ! No interpolation but only a copy of the values of the grid variable 728 861 lb_parent(n) = lb_child(n) 729 s_child(n) = 0. 730 s_parent(n) = 0. 731 ds_child(n) = 1. 732 ds_parent(n) = 1. 862 s_child(n) = 0.d0 863 s_parent(n) = 0.d0 864 ds_child(n) = 1.d0 865 ds_parent(n) = 1.d0 733 866 ! 734 867 end select … … 803 936 do i = 1,nbdim 804 937 ! 938 if (coords(i) == 0) then 939 nbloc(i) = 1 940 locbounds(i,1,1) = lb_glob(i) 941 locbounds(i,2,1) = ub_glob(i) 942 locbounds(i,1,2) = lb_glob(i) 943 locbounds(i,2,2) = ub_glob(i) 944 else 805 945 call Agrif_InvLoc(lb_var(i), rank, coords(i), i1) 806 946 ! … … 816 956 endif 817 957 enddo 958 endif 818 959 enddo 819 960 … … 825 966 ! 826 967 end module Agrif_Arrays 968 969 970 subroutine agrif_set_array_cond_reshape(arrayin,arrayout,value,n) 971 integer :: n 972 real,dimension(n) :: arrayin,arrayout 973 real :: value 974 975 integer :: i 976 977 do i=1,n 978 if (arrayin(i) == value) then 979 arrayout(i) = 0. 980 else 981 arrayout(i) = 1. 982 endif 983 enddo 984 985 end subroutine agrif_set_array_cond_reshape 986 987 subroutine agrif_set_array_tozero_reshape(array,n) 988 integer :: n 989 real,dimension(n) :: array 990 991 integer :: i 992 993 !$OMP PARALLEL DO DEFAULT(none) PRIVATE(i) & 994 !$OMP SHARED(array,n) 995 do i=1,n 996 array(i) = 0. 997 enddo 998 !$OMP END PARALLEL DO 999 1000 end subroutine agrif_set_array_tozero_reshape -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modbc.F90
r5656 r10087 32 32 ! 33 33 implicit none 34 REAL,DIMENSION(:),ALLOCATABLE :: parray_temp 34 35 ! 35 36 contains … … 61 62 integer, dimension(6) :: loctab_child ! Indicates if the child grid has a common border 62 63 ! with the root grid 63 real , dimension(6) :: s_child, s_parent ! Positions of the parent and child grids64 real , dimension(6) :: ds_child, ds_parent ! Space steps of the parent and child grids64 real(kind=8), dimension(6) :: s_child, s_parent ! Positions of the parent and child grids 65 real(kind=8), dimension(6) :: ds_child, ds_parent ! Space steps of the parent and child grids 65 66 ! 66 67 call PreProcessToInterpOrUpdate( parent, child, & … … 145 146 INTEGER, DIMENSION(nbdim) :: posvartab_Child !< Position of the grid variable (1 or 2) 146 147 INTEGER, DIMENSION(nbdim) :: loctab_Child !< Indicates if the child grid has a common border with the root grid 147 REAL , DIMENSION(nbdim) :: s_Child, s_Parent !< Positions of the parent and child grids148 REAL , DIMENSION(nbdim) :: ds_Child, ds_Parent !< Space steps of the parent and child grids148 REAL(kind=8) , DIMENSION(nbdim) :: s_Child, s_Parent !< Positions of the parent and child grids 149 REAL(kind=8) , DIMENSION(nbdim) :: ds_Child, ds_Parent !< Space steps of the parent and child grids 149 150 INTEGER :: nbdim !< Number of dimensions of the grid variable 150 151 procedure() :: procname !< Data recovery procedure … … 159 160 INTEGER,DIMENSION(nbdim,2,2,nbdim) :: ptres,ptres2 ! calculated 160 161 INTEGER,DIMENSION(nbdim) :: coords 161 INTEGER :: i, nb, ndir 162 INTEGER :: i, nb, ndir,j,k,l 162 163 INTEGER :: n, sizetab 163 164 INTEGER :: ibeg, iend 164 165 INTEGER :: i1,i2,j1,j2,k1,k2,l1,l2,m1,m2,n1,n2 165 166 REAL :: c1t,c2t ! Coefficients for the time interpolation (c2t=1-c1t) 167 INTEGER :: isize 168 INTEGER :: kindex_2d(2,nbdim) 169 166 170 #if defined AGRIF_MPI 167 171 ! … … 188 192 END WHERE 189 193 ! 190 call Agrif_get_var_global_bounds(child,lubglob,nbdim) 194 ! call Agrif_get_var_global_bounds(child,lubglob,nbdim) 195 lubglob = child%lubglob(1:nbdim,:) 191 196 ! 192 197 indtruetab(1:nbdim,1,1) = max(indtab(1:nbdim,1,1), lubglob(1:nbdim,1)) … … 194 199 indtruetab(1:nbdim,2,1) = min(indtab(1:nbdim,2,1), lubglob(1:nbdim,2)) 195 200 indtruetab(1:nbdim,2,2) = min(indtab(1:nbdim,2,2), lubglob(1:nbdim,2)) 201 196 202 ! 197 203 do nb = 1,nbdim … … 267 273 if (loctab_child(nb) /= (-ndir) .AND. loctab_child(nb) /= -3) then 268 274 ! 275 269 276 call Agrif_InterpnD(type_interp, parent, child, & 270 277 ptres(1:nbdim,1,ndir,nb), & … … 319 326 do nb = 1,nbdim 320 327 do ndir = 1,2 321 if (loctab_child(nb) /= (-ndir) .AND. loctab_child(nb) /= -3) then 328 kindex_2d(ndir,nb) = kindex 329 if ( (loctab_child(nb) /= (-ndir)) .AND. (loctab_child(nb) /= -3) .AND. child%memberin(nb,ndir) ) then 322 330 Call timeInterpolation(child,ptres2(:,:,ndir,nb),kindex,c1t,c2t,nbdim) 323 331 endif … … 325 333 enddo 326 334 ! 327 endif328 !329 335 do nb = 1,nbdim 330 336 do ndir = 1,2 331 337 if ( (loctab_child(nb) /= (-ndir)) .AND. (loctab_child(nb) /= -3) .AND. child%memberin(nb,ndir) ) then 338 339 do i=1,nbdim 340 if (ptres2(i,1,ndir,nb) /= child%childarray(i,1,2,nb,ndir)) then 341 print *,'problem ptres2 childarray 1 ',ptres2(i,1,ndir,nb) /= child%childarray(i,1,2,nb,ndir) 342 stop 343 endif 344 if (ptres2(i,2,ndir,nb) /= child%childarray(i,2,2,nb,ndir)) then 345 print *,'problem ptres2 childarray 2 ',ptres2(i,2,ndir,nb) /= child%childarray(i,2,2,nb,ndir) 346 stop 347 endif 348 enddo 349 332 350 select case(nbdim) 333 351 case(1) … … 346 364 i1,i2,j1,j2, .FALSE.,coords(nb),ndir) 347 365 case(3) 366 348 367 i1 = child % childarray(1,1,2,nb,ndir) 349 368 i2 = child % childarray(1,2,2,nb,ndir) … … 353 372 k2 = child % childarray(3,2,2,nb,ndir) 354 373 355 call procname(parray3(i1:i2,j1:j2,k1:k2), &356 i1,i2,j1,j2,k1,k2, .FALSE.,coords(nb),ndir) 374 call procname(parray_temp(kindex_2d(ndir,nb)),i1,i2,j1,j2,k1,k2, .FALSE.,coords(nb),ndir) 375 357 376 case(4) 358 377 i1 = child % childarray(1,1,2,nb,ndir) … … 365 384 l2 = child % childarray(4,2,2,nb,ndir) 366 385 367 call procname(parray 4(i1:i2,j1:j2,k1:k2,l1:l2), &368 i1,i2,j1,j2,k1,k2,l1,l2, .FALSE.,coords(nb),ndir) 386 call procname(parray_temp(kindex_2d(ndir,nb)),i1,i2,j1,j2,k1,k2,l1,l2,.FALSE.,coords(nb),ndir) 387 369 388 case(5) 370 389 i1 = child % childarray(1,1,2,nb,ndir) … … 401 420 enddo 402 421 enddo 422 423 else 424 425 do nb = 1,nbdim 426 do ndir = 1,2 427 if ( (loctab_child(nb) /= (-ndir)) .AND. (loctab_child(nb) /= -3) .AND. child%memberin(nb,ndir) ) then 428 select case(nbdim) 429 case(1) 430 i1 = child % childarray(1,1,2,nb,ndir) 431 i2 = child % childarray(1,2,2,nb,ndir) 432 433 call procname(parray1(i1:i2), & 434 i1,i2, .FALSE.,coords(nb),ndir) 435 case(2) 436 i1 = child % childarray(1,1,2,nb,ndir) 437 i2 = child % childarray(1,2,2,nb,ndir) 438 j1 = child % childarray(2,1,2,nb,ndir) 439 j2 = child % childarray(2,2,2,nb,ndir) 440 441 call procname(parray2(i1:i2,j1:j2), & 442 i1,i2,j1,j2, .FALSE.,coords(nb),ndir) 443 case(3) 444 445 i1 = child % childarray(1,1,2,nb,ndir) 446 i2 = child % childarray(1,2,2,nb,ndir) 447 j1 = child % childarray(2,1,2,nb,ndir) 448 j2 = child % childarray(2,2,2,nb,ndir) 449 k1 = child % childarray(3,1,2,nb,ndir) 450 k2 = child % childarray(3,2,2,nb,ndir) 451 452 call procname(parray3(i1:i2,j1:j2,k1:k2), & 453 i1,i2,j1,j2,k1,k2, .FALSE.,coords(nb),ndir) 454 455 case(4) 456 i1 = child % childarray(1,1,2,nb,ndir) 457 i2 = child % childarray(1,2,2,nb,ndir) 458 j1 = child % childarray(2,1,2,nb,ndir) 459 j2 = child % childarray(2,2,2,nb,ndir) 460 k1 = child % childarray(3,1,2,nb,ndir) 461 k2 = child % childarray(3,2,2,nb,ndir) 462 l1 = child % childarray(4,1,2,nb,ndir) 463 l2 = child % childarray(4,2,2,nb,ndir) 464 465 call procname(parray4(i1:i2,j1:j2,k1:k2,l1:l2), & 466 i1,i2,j1,j2,k1,k2,l1,l2, .FALSE.,coords(nb),ndir) 467 468 case(5) 469 i1 = child % childarray(1,1,2,nb,ndir) 470 i2 = child % childarray(1,2,2,nb,ndir) 471 j1 = child % childarray(2,1,2,nb,ndir) 472 j2 = child % childarray(2,2,2,nb,ndir) 473 k1 = child % childarray(3,1,2,nb,ndir) 474 k2 = child % childarray(3,2,2,nb,ndir) 475 l1 = child % childarray(4,1,2,nb,ndir) 476 l2 = child % childarray(4,2,2,nb,ndir) 477 m1 = child % childarray(5,1,2,nb,ndir) 478 m2 = child % childarray(5,2,2,nb,ndir) 479 480 call procname(parray5(i1:i2,j1:j2,k1:k2,l1:l2,m1:m2), & 481 i1,i2,j1,j2,k1,k2,l1,l2,m1,m2, .FALSE.,coords(nb),ndir) 482 case(6) 483 i1 = child % childarray(1,1,2,nb,ndir) 484 i2 = child % childarray(1,2,2,nb,ndir) 485 j1 = child % childarray(2,1,2,nb,ndir) 486 j2 = child % childarray(2,2,2,nb,ndir) 487 k1 = child % childarray(3,1,2,nb,ndir) 488 k2 = child % childarray(3,2,2,nb,ndir) 489 l1 = child % childarray(4,1,2,nb,ndir) 490 l2 = child % childarray(4,2,2,nb,ndir) 491 m1 = child % childarray(5,1,2,nb,ndir) 492 m2 = child % childarray(5,2,2,nb,ndir) 493 n1 = child % childarray(6,1,2,nb,ndir) 494 n2 = child % childarray(6,2,2,nb,ndir) 495 496 call procname(parray6(i1:i2,j1:j2,k1:k2,l1:l2,m1:m2,n1:n2), & 497 i1,i2,j1,j2,k1,k2,l1,l2,m1,m2,n1,n2, .FALSE.,coords(nb),ndir) 498 end select 499 endif 500 enddo 501 enddo 502 503 endif 504 ! 505 403 506 !--------------------------------------------------------------------------------------------------- 404 507 end subroutine Agrif_Correctnd … … 525 628 ! 526 629 INTEGER :: ir,jr,kr,lr,mr,nr 630 INTEGER :: kindexmax, isize,i 631 REAL,DIMENSION(:),ALLOCATABLE :: tabtemp 632 633 isize = 1 634 DO i=1,nbdim 635 isize = isize * (bounds(i,2)-bounds(i,1)+1) 636 ENDDO 637 IF (isize <= 0) RETURN 638 639 kindexmax = kindex + isize - 1 640 IF (.NOT.ALLOCATED(parray_temp)) THEN 641 ALLOCATE(parray_temp(kindexmax)) 642 ELSE 643 IF (size(parray_temp) < kindexmax) THEN 644 ALLOCATE(tabtemp(size(parray_temp))) 645 tabtemp = parray_temp 646 DEALLOCATE(parray_temp) 647 ALLOCATE(parray_temp(kindexmax)) 648 parray_temp(1:size(tabtemp)) = tabtemp 649 DEALLOCATE(tabtemp) 650 ENDIF 651 ENDIF 652 527 653 ! 528 654 SELECT CASE (nbdim) … … 546 672 ! 547 673 CASE (3) 548 do kr = bounds(3,1),bounds(3,2) 549 do jr = bounds(2,1),bounds(2,2) 550 !CDIR ALTCODE 551 do ir = bounds(1,1),bounds(1,2) 552 parray3(ir,jr,kr) = c2t*child_var % oldvalues2d(1,kindex) + & 553 c1t*child_var % oldvalues2d(2,kindex) 554 kindex = kindex + 1 555 enddo 556 enddo 557 enddo 674 675 parray_temp(kindex:kindexmax) = c2t*child_var % oldvalues2d(1,kindex:kindexmax) + & 676 c1t*child_var % oldvalues2d(2,kindex:kindexmax) 677 558 678 ! 559 679 CASE (4) 560 do lr = bounds(4,1),bounds(4,2) 561 do kr = bounds(3,1),bounds(3,2) 562 do jr = bounds(2,1),bounds(2,2) 563 !CDIR ALTCODE 564 do ir = bounds(1,1),bounds(1,2) 565 parray4(ir,jr,kr,lr) = c2t*child_var % oldvalues2d(1,kindex) + & 566 c1t*child_var % oldvalues2d(2,kindex) 567 kindex = kindex + 1 568 enddo 569 enddo 570 enddo 571 enddo 680 681 parray_temp(kindex:kindexmax) = c2t*child_var % oldvalues2d(1,kindex:kindexmax) + & 682 c1t*child_var % oldvalues2d(2,kindex:kindexmax) 683 572 684 ! 573 685 CASE (5) … … 605 717 enddo 606 718 END SELECT 719 720 kindex = kindexmax + 1 721 607 722 !--------------------------------------------------------------------------------------------------- 608 723 end subroutine timeInterpolation -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modbcfunction.F90
r5656 r10087 21 21 ! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 22 22 ! 23 !--------------------------------------------------------------------------------------------------- 23 24 !> Module Agrif_BcFunction. 24 ! 25 !! 26 !--------------------------------------------------------------------------------------------------- 25 27 module Agrif_BcFunction 26 28 ! 27 29 ! Modules used: 28 30 ! 29 use Agrif_Boundary 30 use Agrif_Update 31 use Agrif_Save 31 use Agrif_User_Variables 32 32 33 ! 33 34 implicit none 34 !35 interface Agrif_Set_Parent36 module procedure Agrif_Set_Parent_int, &37 Agrif_Set_Parent_real4, &38 Agrif_Set_Parent_real839 end interface40 35 ! 41 36 interface Agrif_Save_Forrestore … … 47 42 ! 48 43 contains 49 ! 50 !=================================================================================================== 51 ! subroutine Agrif_Set_parent_int 52 ! 53 !> To set the TYPE of the variable 54 !--------------------------------------------------------------------------------------------------- 55 subroutine Agrif_Set_parent_int(tabvarsindic,value) 56 !--------------------------------------------------------------------------------------------------- 57 integer, intent(in) :: tabvarsindic !< indice of the variable in tabvars 58 integer, intent(in) :: value !< input value 59 ! 60 Agrif_Curgrid % parent % tabvars_i(tabvarsindic) % iarray0 = value 61 !--------------------------------------------------------------------------------------------------- 62 end subroutine Agrif_Set_parent_int 63 !=================================================================================================== 64 ! 65 !=================================================================================================== 66 ! subroutine Agrif_Set_parent_real4 67 !--------------------------------------------------------------------------------------------------- 68 !> To set the TYPE of the variable 69 !--------------------------------------------------------------------------------------------------- 70 subroutine Agrif_Set_parent_real4 ( tabvarsindic, value ) 71 !--------------------------------------------------------------------------------------------------- 72 integer, intent(in) :: tabvarsindic !< indice of the variable in tabvars 73 real(kind=4),intent(in) :: value !< input value 74 ! 75 Agrif_Curgrid % parent % tabvars_r(tabvarsindic) % array0 = value 76 Agrif_Curgrid % parent % tabvars_r(tabvarsindic) % sarray0 = value 77 !--------------------------------------------------------------------------------------------------- 78 end subroutine Agrif_Set_parent_real4 79 !=================================================================================================== 80 ! 81 !=================================================================================================== 82 ! subroutine Agrif_Set_parent_real8 83 !--------------------------------------------------------------------------------------------------- 84 !> To set the TYPE of the variable 85 !--------------------------------------------------------------------------------------------------- 86 subroutine Agrif_Set_parent_real8 ( tabvarsindic, value ) 87 !--------------------------------------------------------------------------------------------------- 88 integer, intent(in) :: tabvarsindic !< indice of the variable in tabvars 89 real(kind=8),intent(in) :: value !< input value 90 ! 91 Agrif_Curgrid % parent % tabvars_r(tabvarsindic) % darray0 = value 92 !--------------------------------------------------------------------------------------------------- 93 end subroutine Agrif_Set_parent_real8 94 !=================================================================================================== 95 ! 96 !=================================================================================================== 97 ! subroutine Agrif_Set_bc 98 !--------------------------------------------------------------------------------------------------- 99 subroutine Agrif_Set_bc ( tabvarsindic, bcinfsup, Interpolationshouldbemade ) 100 !--------------------------------------------------------------------------------------------------- 101 integer, intent(in) :: tabvarsindic !< indice of the variable in tabvars 102 integer, dimension(2), intent(in) :: bcinfsup !< bcinfsup 103 logical, optional, intent(in) :: Interpolationshouldbemade !< interpolation should be made 104 ! 105 integer :: indic ! indice of the variable in tabvars 106 type(Agrif_Variable), pointer :: var 107 ! 108 indic = Agrif_Curgrid % tabvars_i(tabvarsindic) % iarray0 109 ! 110 if (indic <= 0) then 111 var => Agrif_Search_Variable(Agrif_Curgrid,-indic) 112 else 113 print*,"Agrif_Set_bc : warning indic >= 0 !!!" 114 var => Agrif_Curgrid % tabvars(indic) 115 endif 116 117 if (.not.associated(var)) return ! Grand mother grid case 118 ! 119 if ( Agrif_Curgrid % fixedrank /= 0 ) then 120 if ( .not.associated(var % oldvalues2D) ) then 121 allocate(var % oldvalues2D(2,1)) 122 var % interpIndex = -1 123 var % oldvalues2D = 0. 124 endif 125 if ( present(Interpolationshouldbemade) ) then 126 var % Interpolationshouldbemade = Interpolationshouldbemade 127 endif 128 endif 129 ! 130 var % bcinf = bcinfsup(1) 131 var % bcsup = bcinfsup(2) 132 !--------------------------------------------------------------------------------------------------- 133 end subroutine Agrif_Set_bc 134 !=================================================================================================== 135 ! 136 !=================================================================================================== 137 ! subroutine Agrif_Set_interp 138 !--------------------------------------------------------------------------------------------------- 139 subroutine Agrif_Set_interp ( tabvarsindic, interp, interp1, interp2, interp3 , interp4) 140 !--------------------------------------------------------------------------------------------------- 141 integer, intent(in) :: tabvarsindic !< indice of the variable in tabvars 142 integer, optional, intent(in) :: interp, interp1, interp2, interp3, interp4 143 ! 144 integer :: indic ! indice of the variable in tabvars 145 type(Agrif_Variable), pointer :: var 146 ! 147 indic = Agrif_Curgrid % tabvars_i(tabvarsindic) % iarray0 148 ! 149 if (indic <= 0) then 150 var => Agrif_Search_Variable(Agrif_Mygrid,-indic) 151 else 152 print*,"Agrif_Set_interp : warning indic >= 0 !!!" 153 var => Agrif_Mygrid % tabvars(indic) 154 endif 155 ! 156 var % type_interp = Agrif_Constant 157 ! 158 if (present(interp)) var % type_interp = interp 159 if (present(interp1)) var % type_interp(1) = interp1 160 if (present(interp2)) var % type_interp(2) = interp2 161 if (present(interp3)) var % type_interp(3) = interp3 162 if (present(interp4)) var % type_interp(4) = interp4 163 !--------------------------------------------------------------------------------------------------- 164 end subroutine Agrif_Set_interp 165 !=================================================================================================== 166 ! 167 !=================================================================================================== 168 ! subroutine Agrif_Set_bcinterp 169 !--------------------------------------------------------------------------------------------------- 170 subroutine Agrif_Set_bcinterp ( tabvarsindic, interp, interp1, interp2, interp3, interp4, & 171 interp11, interp12, interp21, interp22 ) 172 !--------------------------------------------------------------------------------------------------- 173 INTEGER, intent(in) :: tabvarsindic !< indice of the variable in tabvars 174 INTEGER, OPTIONAL, intent(in) :: interp, interp1, interp2, interp3, interp4 175 INTEGER, OPTIONAL, intent(in) :: interp11, interp12, interp21, interp22 176 ! 177 INTEGER :: indic ! indice of the variable in tabvars 178 TYPE(Agrif_Variable), pointer :: var 179 ! 44 45 !=================================================================================================== 46 ! subroutine Agrif_Set_restore 47 !> This subroutine is used to set the index of the current grid variable we want to restore. 48 !--------------------------------------------------------------------------------------------------- 49 subroutine Agrif_Set_restore ( tabvarsindic ) 50 !--------------------------------------------------------------------------------------------------- 51 INTEGER, intent(in) :: tabvarsindic !< indice of the variable in tabvars 52 ! 53 INTEGER :: indic ! indice of the variable in tabvars 54 ! 55 print *,'CURRENTLY BROKEN' 56 STOP 57 180 58 indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0 181 59 ! 182 if (indic <= 0) then183 var => Agrif_Search_Variable(Agrif_Mygrid,-indic)184 else185 print*,"Agrif_Set_bcinterp : warning indic >= 0 !!!"186 var => Agrif_Mygrid % tabvars(indic)187 endif188 !189 var % type_interp_bc = Agrif_Constant190 !191 if (present(interp)) var % type_interp_bc = interp192 if (present(interp1)) var % type_interp_bc(:,1) = interp1193 if (present(interp11)) var % type_interp_bc(1,1) = interp11194 if (present(interp12)) var % type_interp_bc(1,2) = interp12195 if (present(interp2)) var % type_interp_bc(:,2) = interp2196 if (present(interp21)) var % type_interp_bc(2,1) = interp21197 if (present(interp22)) var % type_interp_bc(2,2) = interp22198 if (present(interp3)) var % type_interp_bc(:,3) = interp3199 if (present(interp4)) var % type_interp_bc(:,4) = interp4200 !---------------------------------------------------------------------------------------------------201 end subroutine Agrif_Set_bcinterp202 !===================================================================================================203 !204 !===================================================================================================205 ! subroutine Agrif_Set_UpdateType206 !---------------------------------------------------------------------------------------------------207 subroutine Agrif_Set_UpdateType ( tabvarsindic, update, update1, update2, &208 update3, update4, update5 )209 !---------------------------------------------------------------------------------------------------210 INTEGER, intent(in) :: tabvarsindic !< indice of the variable in tabvars211 INTEGER, OPTIONAL, intent(in) :: update, update1, update2, update3, update4, update5212 !213 INTEGER :: indic ! indice of the variable in tabvars214 type(Agrif_Variable), pointer :: root_var215 !216 indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0217 !218 if (indic <= 0) then219 root_var => Agrif_Search_Variable(Agrif_Mygrid,-indic)220 else221 print*,"Agrif_Set_UpdateType : warning indic >= 0 !!!"222 root_var => Agrif_Mygrid % tabvars(indic)223 endif224 !225 root_var % type_update = Agrif_Update_Copy226 if (present(update)) root_var % type_update = update227 if (present(update1)) root_var % type_update(1) = update1228 if (present(update2)) root_var % type_update(2) = update2229 if (present(update3)) root_var % type_update(3) = update3230 if (present(update4)) root_var % type_update(4) = update4231 if (present(update5)) root_var % type_update(5) = update5232 !---------------------------------------------------------------------------------------------------233 end subroutine Agrif_Set_UpdateType234 !===================================================================================================235 !236 !===================================================================================================237 ! subroutine Agrif_Set_restore238 !---------------------------------------------------------------------------------------------------239 subroutine Agrif_Set_restore ( tabvarsindic )240 !---------------------------------------------------------------------------------------------------241 INTEGER, intent(in) :: tabvarsindic !< indice of the variable in tabvars242 !243 INTEGER :: indic ! indice of the variable in tabvars244 !245 indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0246 !247 60 Agrif_Mygrid%tabvars(indic) % restore = .TRUE. 248 61 !--------------------------------------------------------------------------------------------------- … … 251 64 ! 252 65 !=================================================================================================== 253 ! subroutine Agrif_Init_variable254 !---------------------------------------------------------------------------------------------------255 subroutine Agrif_Init_variable ( tabvarsindic, procname )256 !---------------------------------------------------------------------------------------------------257 INTEGER, intent(in) :: tabvarsindic !< indice of the variable in tabvars258 procedure() :: procname !< Data recovery procedure259 !260 if ( Agrif_Curgrid%level <= 0 ) return261 !262 call Agrif_Interp_variable(tabvarsindic, procname)263 call Agrif_Bc_variable(tabvarsindic, procname, 1.)264 !---------------------------------------------------------------------------------------------------265 end subroutine Agrif_Init_variable266 !===================================================================================================267 !268 !===================================================================================================269 ! subroutine Agrif_Bc_variable270 !---------------------------------------------------------------------------------------------------271 subroutine Agrif_Bc_variable ( tabvarsindic, procname, calledweight )272 !---------------------------------------------------------------------------------------------------273 integer, intent(in) :: tabvarsindic !< indice of the variable in tabvars274 procedure() :: procname275 real, optional, intent(in) :: calledweight276 !277 real :: weight278 logical :: pweight279 integer :: indic280 integer :: nbdim281 type(Agrif_Variable), pointer :: root_var282 type(Agrif_Variable), pointer :: parent_var283 type(Agrif_Variable), pointer :: child_var284 type(Agrif_Variable), pointer :: child_tmp ! Temporary variable on the child grid285 !286 if ( Agrif_Curgrid%level <= 0 ) return287 !288 indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0289 !290 if ( present(calledweight) ) then291 weight = calledweight292 pweight = .true.293 else294 weight = 0.295 pweight = .false.296 endif297 !298 if (indic <= 0) then299 child_var => Agrif_Search_Variable(Agrif_Curgrid,-indic)300 parent_var => child_var % parent_var301 root_var => child_var % root_var302 else303 print*,"Agrif_Bc_variable : warning indic >= 0 !!!"304 child_var => Agrif_Curgrid % tabvars(indic)305 parent_var => Agrif_Curgrid % parent % tabvars(indic)306 root_var => Agrif_Mygrid % tabvars(indic)307 endif308 !309 nbdim = root_var % nbdim310 !311 select case( nbdim )312 case(1)313 allocate(parray1(child_var%lb(1):child_var%ub(1)))314 case(2)315 allocate(parray2(child_var%lb(1):child_var%ub(1), &316 child_var%lb(2):child_var%ub(2) ))317 case(3)318 allocate(parray3(child_var%lb(1):child_var%ub(1), &319 child_var%lb(2):child_var%ub(2), &320 child_var%lb(3):child_var%ub(3) ))321 case(4)322 allocate(parray4(child_var%lb(1):child_var%ub(1), &323 child_var%lb(2):child_var%ub(2), &324 child_var%lb(3):child_var%ub(3), &325 child_var%lb(4):child_var%ub(4) ))326 case(5)327 allocate(parray5(child_var%lb(1):child_var%ub(1), &328 child_var%lb(2):child_var%ub(2), &329 child_var%lb(3):child_var%ub(3), &330 child_var%lb(4):child_var%ub(4), &331 child_var%lb(5):child_var%ub(5) ))332 case(6)333 allocate(parray6(child_var%lb(1):child_var%ub(1), &334 child_var%lb(2):child_var%ub(2), &335 child_var%lb(3):child_var%ub(3), &336 child_var%lb(4):child_var%ub(4), &337 child_var%lb(5):child_var%ub(5), &338 child_var%lb(6):child_var%ub(6) ))339 end select340 !341 ! Create temporary child variable342 allocate(child_tmp)343 !344 child_tmp % root_var => root_var345 child_tmp % oldvalues2D => child_var % oldvalues2D346 !347 ! Index indicating if a space interpolation is necessary348 child_tmp % interpIndex = child_var % interpIndex349 child_tmp % list_interp => child_var % list_interp350 child_tmp % Interpolationshouldbemade = child_var % Interpolationshouldbemade351 !352 child_tmp % point = child_var % point353 child_tmp % lb = child_var % lb354 child_tmp % ub = child_var % ub355 !356 child_tmp % bcinf = child_var % bcinf357 child_tmp % bcsup = child_var % bcsup358 !359 child_tmp % childarray = child_var % childarray360 child_tmp % memberin = child_var % memberin361 !362 call Agrif_CorrectVariable(parent_var, child_tmp, pweight, weight, procname)363 !364 child_var % childarray = child_tmp % childarray365 child_var % memberin = child_tmp % memberin366 !367 child_var % oldvalues2D => child_tmp % oldvalues2D368 child_var % list_interp => child_tmp % list_interp369 !370 child_var % interpIndex = child_tmp % interpIndex371 !372 deallocate(child_tmp)373 !374 select case( nbdim )375 case(1); deallocate(parray1)376 case(2); deallocate(parray2)377 case(3); deallocate(parray3)378 case(4); deallocate(parray4)379 case(5); deallocate(parray5)380 case(6); deallocate(parray6)381 end select382 !---------------------------------------------------------------------------------------------------383 end subroutine Agrif_Bc_variable384 !===================================================================================================385 !386 !===================================================================================================387 ! subroutine Agrif_Interp_variable388 !---------------------------------------------------------------------------------------------------389 subroutine Agrif_Interp_variable ( tabvarsindic, procname )390 !---------------------------------------------------------------------------------------------------391 integer, intent(in) :: tabvarsindic !< indice of the variable in tabvars392 procedure() :: procname !< Data recovery procedure393 !394 integer :: nbdim395 integer :: indic ! indice of the variable in tabvars396 logical :: torestore397 type(Agrif_Variable), pointer :: root_var398 type(Agrif_Variable), pointer :: parent_var ! Variable on the parent grid399 type(Agrif_Variable), pointer :: child_var ! Variable on the parent grid400 type(Agrif_Variable), pointer :: child_tmp ! Temporary variable on the child grid401 !402 if ( Agrif_Curgrid%level <= 0 ) return403 !404 indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0405 !406 if (indic <= 0) then407 child_var => Agrif_Search_Variable(Agrif_Curgrid,-indic)408 parent_var => child_var % parent_var409 root_var => child_var % root_var410 else411 print*,"Agrif_Interp_variable : warning indic >= 0 !!!"412 child_var => Agrif_Curgrid % tabvars(indic)413 parent_var => Agrif_Curgrid % parent % tabvars(indic)414 root_var => Agrif_Mygrid % tabvars(indic)415 endif416 !417 nbdim = root_var % nbdim418 torestore = root_var % restore419 !420 allocate(child_tmp)421 !422 child_tmp % root_var => root_var423 child_tmp % nbdim = root_var % nbdim424 child_tmp % point = child_var % point425 child_tmp % lb = child_var % lb426 child_tmp % ub = child_var % ub427 child_tmp % interpIndex = child_var % interpIndex428 child_tmp % list_interp => child_var % list_interp429 child_tmp % Interpolationshouldbemade = child_var % Interpolationshouldbemade430 !431 if ( torestore ) then432 select case( nbdim )433 case(1)434 parray1 = child_var % array1435 child_tmp % restore1D => child_var % restore1D436 case(2)437 parray2 = child_var % array2438 child_tmp % restore2D => child_var % restore2D439 case(3)440 parray3 = child_var % array3441 child_tmp % restore3D => child_var % restore3D442 case(4)443 parray4 = child_var % array4444 child_tmp % restore4D => child_var % restore4D445 case(5)446 parray5 = child_var % array5447 child_tmp % restore5D => child_var % restore5D448 case(6)449 parray6 = child_var % array6450 child_tmp % restore6D => child_var % restore6D451 end select452 endif453 !454 call Agrif_InterpVariable(parent_var, child_tmp, torestore, procname)455 !456 child_var % list_interp => child_tmp % list_interp457 !458 deallocate(child_tmp)459 !---------------------------------------------------------------------------------------------------460 end subroutine Agrif_Interp_variable461 !===================================================================================================462 !463 !===================================================================================================464 ! subroutine Agrif_Update_Variable465 !---------------------------------------------------------------------------------------------------466 subroutine Agrif_Update_Variable ( tabvarsindic, procname, &467 locupdate, locupdate1, locupdate2, locupdate3, locupdate4 )468 !---------------------------------------------------------------------------------------------------469 integer, intent(in) :: tabvarsindic !< Indice of the variable in tabvars470 procedure() :: procname !< Data recovery procedure471 integer, dimension(2), intent(in), optional :: locupdate472 integer, dimension(2), intent(in), optional :: locupdate1473 integer, dimension(2), intent(in), optional :: locupdate2474 integer, dimension(2), intent(in), optional :: locupdate3475 integer, dimension(2), intent(in), optional :: locupdate4476 !---------------------------------------------------------------------------------------------------477 integer :: indic478 integer :: nbdim479 integer, dimension(6) :: updateinf ! First positions where interpolations are calculated480 integer, dimension(6) :: updatesup ! Last positions where interpolations are calculated481 type(Agrif_Variable), pointer :: root_var482 type(Agrif_Variable), pointer :: parent_var483 type(Agrif_Variable), pointer :: child_var484 !485 if ( Agrif_Root() .AND. (.not.agrif_coarse) ) return486 if (agrif_curgrid%grand_mother_grid) return487 !488 indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0489 !490 if (indic <= 0) then491 child_var => Agrif_Search_Variable(Agrif_Curgrid, -indic)492 parent_var => child_var % parent_var493 494 if (.not.associated(parent_var)) then495 ! can occur during the first update of Agrif_Coarsegrid (if any)496 parent_var => Agrif_Search_Variable(Agrif_Curgrid % parent, -indic)497 child_var % parent_var => parent_var498 endif499 500 root_var => child_var % root_var501 else502 print*,"Agrif_Update_Variable : warning indic >= 0 !!!"503 root_var => Agrif_Mygrid % tabvars(indic)504 child_var => Agrif_Curgrid % tabvars(indic)505 parent_var => Agrif_Curgrid % parent % tabvars(indic)506 endif507 !508 nbdim = root_var % nbdim509 !510 updateinf = -99511 updatesup = -99512 !513 if ( present(locupdate) ) then514 updateinf(1:nbdim) = locupdate(1)515 updatesup(1:nbdim) = locupdate(2)516 endif517 !518 if ( present(locupdate1) ) then519 updateinf(1) = locupdate1(1)520 updatesup(1) = locupdate1(2)521 endif522 !523 if ( present(locupdate2) ) then524 updateinf(2) = locupdate2(1)525 updatesup(2) = locupdate2(2)526 endif527 528 if ( present(locupdate3) ) then529 updateinf(3) = locupdate3(1)530 updatesup(3) = locupdate3(2)531 endif532 533 if ( present(locupdate4) ) then534 updateinf(4) = locupdate4(1)535 updatesup(4) = locupdate4(2)536 endif537 !538 call Agrif_UpdateVariable( parent_var, child_var, updateinf, updatesup, procname )539 !---------------------------------------------------------------------------------------------------540 end subroutine Agrif_Update_Variable541 !===================================================================================================542 !543 !===================================================================================================544 66 ! subroutine Agrif_Save_ForRestore0D 545 67 !--------------------------------------------------------------------------------------------------- 546 68 subroutine Agrif_Save_ForRestore0D ( tabvarsindic0, tabvarsindic ) 547 69 !--------------------------------------------------------------------------------------------------- 548 integer, intent(in) :: tabvarsindic0, tabvarsindic 70 integer, intent(in) :: tabvarsindic0 !< index of the current grid variable 71 integer, intent(in) :: tabvarsindic !< index of the varible which should be restored 72 549 73 ! 550 74 type(Agrif_Variable), pointer :: root_var, save_var 551 75 integer :: nbdim 552 76 ! 77 print *,'CURRENTLY BROKEN' 78 STOP 553 79 root_var => Agrif_Mygrid % tabvars(tabvarsindic0) 554 80 save_var => Agrif_Curgrid % tabvars(tabvarsindic0) … … 566 92 !=================================================================================================== 567 93 ! subroutine Agrif_Save_ForRestore2D 94 !> This function is used to restore a current grid variable (with the index tabvarsindic) to the input 2D-variable. 568 95 !--------------------------------------------------------------------------------------------------- 569 96 subroutine Agrif_Save_ForRestore2D ( q, tabvarsindic ) 570 97 !--------------------------------------------------------------------------------------------------- 571 real, dimension(:,:), intent(in) :: q 572 integer, intent(in) :: tabvarsindic 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 573 101 ! 574 102 type(Agrif_Variable), pointer :: root_var, save_var 575 103 integer :: indic 576 104 ! 105 print *,'CURRENTLY BROKEN' 106 STOP 577 107 indic = tabvarsindic 578 108 if (tabvarsindic >= 0) then … … 603 133 !=================================================================================================== 604 134 ! subroutine Agrif_Save_ForRestore3D 135 !> This function is used to restore a current grid variable (with the index tabvarsindic) to the input 3D-variable. 605 136 !--------------------------------------------------------------------------------------------------- 606 137 subroutine Agrif_Save_ForRestore3D ( q, tabvarsindic ) 607 138 !--------------------------------------------------------------------------------------------------- 608 real, dimension(:,:,:), intent(in) :: q 609 integer, intent(in) :: tabvarsindic 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 610 142 ! 611 143 type(Agrif_Variable), pointer :: root_var, save_var 612 144 integer :: indic 613 145 ! 146 print *,'CURRENTLY BROKEN' 147 STOP 148 614 149 indic = tabvarsindic 615 150 if (tabvarsindic >= 0) then … … 641 176 !=================================================================================================== 642 177 ! subroutine Agrif_Save_ForRestore4D 178 !> This function is used to restore a current grid variable (with the index tabvarsindic) to the input 4D-variable. 643 179 !--------------------------------------------------------------------------------------------------- 644 180 subroutine Agrif_Save_ForRestore4D ( q, tabvarsindic ) 645 181 !--------------------------------------------------------------------------------------------------- 646 real, dimension(:,:,:,:), intent(in) :: q 647 integer, intent(in) :: tabvarsindic 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 ! 648 186 ! 649 187 type(Agrif_Variable), pointer :: root_var, save_var 650 188 integer :: indic 651 189 ! 190 print *,'CURRENTLY BROKEN' 191 STOP 652 192 indic = tabvarsindic 653 193 if (tabvarsindic >= 0) then -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modcluster.F90
r5656 r10087 29 29 module Agrif_Clustering 30 30 ! 31 use Agrif_CurgridFunctions 31 !use Agrif_CurgridFunctions 32 !use Agrif_Init_Vars 33 !use Agrif_Save 32 34 use Agrif_Init_Vars 33 35 use Agrif_Save 36 use Agrif_Init 34 37 ! 35 38 implicit none … … 54 57 TYPE(Agrif_LRectangle), pointer :: parcours 55 58 TYPE(Agrif_Grid) , pointer :: newgrid 56 REAL 59 REAL(kind=8) :: g_eps 57 60 INTEGER :: i 58 61 ! … … 131 134 TYPE(Agrif_PGrid), pointer :: parcours 132 135 ! 133 REAL :: g_eps, newgrid_eps, eps134 REAL , DIMENSION(3) :: newmin, newmax135 REAL , DIMENSION(3) :: gmin, gmax136 REAL , DIMENSION(3) :: xmin136 REAL(kind=8) :: g_eps, newgrid_eps, eps 137 REAL(kind=8) , DIMENSION(3) :: newmin, newmax 138 REAL(kind=8) , DIMENSION(3) :: gmin, gmax 139 REAL(kind=8) , DIMENSION(3) :: xmin 137 140 INTEGER, DIMENSION(3) :: igmin, inewmin 138 141 INTEGER, DIMENSION(3) :: inewmax -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modcurgridfunctions.F90
r5656 r10087 92 92 ! 93 93 rhot = float(Agrif_IRhot()) 94 94 95 !--------------------------------------------------------------------------------------------------- 95 96 end function Agrif_Rhot -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modgrids.F90
r5656 r10087 44 44 type(Agrif_Variable_i), dimension(:), allocatable :: tabvars_i !< List of integer grid variables 45 45 ! 46 real , dimension(3):: Agrif_x !< global x, y and z position47 real , 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(kind=8), dimension(3) :: Agrif_x !< global x, y and z position 47 real(kind=8) , dimension(3) :: Agrif_dx !< global space step in the x, y and z direction 48 real, dimension(3) :: Agrif_dt !< global time step in the x, y and z direction 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
r5656 r10087 31 31 ! 32 32 implicit none 33 34 abstract interface 35 subroutine step_proc() 36 end subroutine step_proc 37 end interface 38 33 39 ! 34 40 contains 35 41 ! 42 43 44 subroutine Agrif_call_procname ( procname ) 45 procedure(step_proc) :: procname 46 call procname() 47 end subroutine Agrif_call_procname 48 !=================================================================================================== 49 50 subroutine Agrif_call_procname1 ( procname1 ) 51 procedure(typedef_proc) :: procname1 52 call procname1() 53 end subroutine Agrif_call_procname1 54 36 55 !=================================================================================================== 37 56 ! subroutine Agrif_Allocation -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modinterp.F90
r7752 r10087 26 26 module Agrif_Interpolation 27 27 ! 28 use Agrif_InterpBasic 29 use Agrif_Arrays 30 use Agrif_Mask 31 use Agrif_CurgridFunctions 28 use Agrif_Init 29 use Agrif_Arrays 30 use Agrif_InterpBasic 31 use Agrif_User_Functions 32 32 33 #if defined AGRIF_MPI 33 34 use Agrif_Mpp 34 35 #endif 36 37 use Agrif_Mask 35 38 ! 36 39 implicit none … … 66 69 integer, dimension(6) :: ub_child 67 70 integer, dimension(6) :: lb_parent 68 real , dimension(6) :: s_child, s_parent69 real , dimension(6) :: ds_child, ds_parent71 real(kind=8) , dimension(6) :: s_child, s_parent 72 real(kind=8) , dimension(6) :: ds_child, ds_parent 70 73 integer, dimension(child % root_var % nbdim,2,2) :: childarray 71 74 ! … … 115 118 INTEGER, DIMENSION(nbdim), INTENT(in) :: pttab_Parent !< Index of the first point inside the domain 116 119 !< for the parent grid variable 117 REAL , DIMENSION(nbdim), INTENT(in) :: s_Child,s_Parent !< Positions of the parent and child grids118 REAL , DIMENSION(nbdim), INTENT(in) :: ds_Child,ds_Parent !< Space steps of the parent and child grids120 REAL(kind=8), DIMENSION(nbdim), INTENT(in) :: s_Child,s_Parent !< Positions of the parent and child grids 121 REAL(kind=8), DIMENSION(nbdim), INTENT(in) :: ds_Child,ds_Parent !< Space steps of the parent and child grids 119 122 TYPE(Agrif_Variable), pointer :: restore !< Indicates points where interpolation 120 123 LOGICAL, INTENT(in) :: torestore !< Indicates if the array restore is used … … 128 131 INTEGER :: i,j,k,l,m,n 129 132 INTEGER, DIMENSION(nbdim) :: pttruetab,cetruetab 130 INTEGER, DIMENSION(nbdim) :: indmin, indmax 133 INTEGER, DIMENSION(nbdim) :: indmin, indmax, indmin_required_p, indmax_required_p 131 134 INTEGER, DIMENSION(nbdim) :: indminglob, indmaxglob 132 135 #if defined AGRIF_MPI 133 136 INTEGER, DIMENSION(nbdim) :: indminglob2,indmaxglob2 137 INTEGER, DIMENSION(nbdim) :: indminglob3,indmaxglob3 134 138 #endif 135 139 LOGICAL, DIMENSION(nbdim) :: noraftab 136 REAL , DIMENSION(nbdim) :: s_Child_temp,s_Parent_temp140 REAL(kind=8) , DIMENSION(nbdim) :: s_Child_temp,s_Parent_temp,s_Parent_temp_p 137 141 INTEGER, DIMENSION(nbdim) :: lowerbound, upperbound, coords 138 142 INTEGER, DIMENSION(nbdim,2,2), INTENT(OUT) :: childarray … … 148 152 INTEGER, DIMENSION(nbdim,4,0:Agrif_Nbprocs-1) :: tab4 149 153 INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1,8) :: tab4t 154 INTEGER,DIMENSION(nbdim,2) :: tab5 155 INTEGER,DIMENSION(nbdim,2,0:Agrif_Nbprocs-1) :: tab6 156 INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,2) :: tab5t 150 157 LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: memberinall 151 158 LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: sendtoproc1, recvfromproc1 … … 167 174 child % list_interp, & 168 175 pttab, petab, pttab_Child, pttab_Parent, nbdim, & 169 indmin, indmax, indminglob, indmaxglob, & 176 indmin, indmax, indmin_required_p, indmax_required_p, & 177 indminglob, indmaxglob, & 170 178 pttruetab, cetruetab, memberin & 171 179 #if defined AGRIF_MPI … … 174 182 #endif 175 183 ) 184 176 185 ! 177 186 if (.not.find_list_interp) then 178 187 ! 188 ! output : lowerbound and upperbound are the (local) lower and upper bounds of the child arrays 189 179 190 call Agrif_get_var_bounds_array(child, lowerbound, upperbound, nbdim) 191 192 ! input : pttab, petab : global indexes where the interpolation is required 193 ! output : pttruetab, cetruetab : global indexes restricted to the bounds of the current processor 194 ! output : memberin is false if the current processor is not involved in the interpolation 195 180 196 call Agrif_Childbounds(nbdim, lowerbound, upperbound, & 181 197 pttab, petab, Agrif_Procrank, coords, & 182 198 pttruetab, cetruetab, memberin) 199 200 201 202 ! output : indminglob, indmaxglob : global indexes required on the parent grid for the interpolation 203 ! output : s_Parent_temp, s_Child_temp : local s_Parent, s_Child relatively to indmin ou pttab 183 204 call Agrif_Parentbounds(type_interp,nbdim,indminglob,indmaxglob, & 205 indmin_required_p, indmax_required_p, & 184 206 s_Parent_temp,s_Child_temp, & 185 207 s_Child,ds_Child, & … … 190 212 #if defined AGRIF_MPI 191 213 if (memberin) then 214 215 ! output : indmin, indmax : global indexes required on the parent grid for the interpolation on the current processor (i.e. on pttruetab, cetruetab) 216 ! output : s_Parent_temp, s_Child_temp : local s_Parent, s_Child relatively to indmin ou pttruetab 192 217 call Agrif_Parentbounds(type_interp,nbdim,indmin,indmax, & 218 indmin_required_p, indmax_required_p, & 193 219 s_Parent_temp,s_Child_temp, & 194 220 s_Child,ds_Child, & … … 200 226 201 227 local_proc = Agrif_Procrank 228 229 ! output : lowerbound and upperbound are the (local) lower and upper bounds of the parent arrays 202 230 call Agrif_get_var_bounds_array(parent,lowerbound,upperbound,nbdim) 203 231 call Agrif_ChildGrid_to_ParentGrid() 204 ! 232 233 ! input : indminglob,indmaxglob : global indexes where data are required for the interpolation 234 ! output : indminglob2,indmaxglob2 : global indexes restricted to the bounds of the current processor 235 ! output : member is false if the current processor does not need to send data 236 ! output : indminglob3,indmaxglob3 : global bounds on the current processor for the parent array 237 205 238 call Agrif_Childbounds(nbdim,lowerbound,upperbound, & 206 239 indminglob,indmaxglob, local_proc, coords, & 207 indminglob2,indmaxglob2,member) 240 indminglob2,indmaxglob2,member, & 241 indminglob3,indmaxglob3) 208 242 ! 209 243 if (member) then 244 245 ! output : parentarray 246 ! output : parentarray (:,:,2) : indminglob2, indmaxglob2 in term of local indexes on current processor 247 ! output : parentarray (:,:,1) : indminglob2, indmaxglob2 restricted to the current processor (different from indminglob2 ???) 248 ! output : member is .false. is the current processor has not data to send 249 210 250 call Agrif_GlobalToLocalBounds(parentarray, & 211 251 lowerbound, upperbound, & … … 216 256 call Agrif_ParentGrid_to_ChildGrid() 217 257 #else 258 259 ! In the sequentiel case, the following lines ensure that the bounds needed on the parent grid in the interpolation 260 ! do not exceed lower and upper bounds of the parent array 261 262 ! output : lowerbound and upperbound are the (local) lower and upper bounds of the parent arrays 263 call Agrif_get_var_bounds_array(parent,lowerbound,upperbound,nbdim) 264 call Agrif_ChildGrid_to_ParentGrid() 265 266 ! input : indminglob,indmaxglob : global indexes where data are required for the interpolation 267 ! output : indminglob2,indmaxglob2 : global indexes restricted to the bounds of the current processor 268 ! output : member is false if the current processor does not need to send data 269 270 call Agrif_Childbounds(nbdim,lowerbound,upperbound, & 271 indminglob,indmaxglob, Agrif_Procrank, coords, & 272 indmin,indmax,member) 273 274 call Agrif_ParentGrid_to_ChildGrid() 275 276 indminglob = indmin 277 indmaxglob = indmax 278 218 279 parentarray(:,1,1) = indminglob 219 280 parentarray(:,2,1) = indmaxglob 220 281 parentarray(:,1,2) = indminglob 221 282 parentarray(:,2,2) = indmaxglob 222 indmin = indminglob 223 indmax = indmaxglob 283 284 ! indmin = indminglob 285 ! indmax = indmaxglob 286 224 287 member = .TRUE. 288 s_Parent_temp = s_Parent + (indminglob - pttab_Parent) * ds_Parent 289 225 290 #endif 291 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 292 ! Correct for non refined directions 293 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 294 do i=1,nbdim 295 if (coords(i) == 0) then 296 indmin(i) = indminglob(i) 297 indmax(i) = indmaxglob(i) 298 pttruetab(i) = indminglob(i) 299 cetruetab(i) = indmaxglob(i) 300 endif 301 enddo 226 302 227 303 else … … 231 307 s_Child_temp = s_Child + (pttruetab - pttab_Child) * ds_Child 232 308 #else 309 310 ! In the sequentiel case, the following lines ensure that the bounds needed on the parent grid in the interpolation 311 ! do not exceed lower and upper bounds of the parent array 312 313 ! output : lowerbound and upperbound are the (local) lower and upper bounds of the parent arrays 314 call Agrif_get_var_bounds_array(parent,lowerbound,upperbound,nbdim) 315 call Agrif_ChildGrid_to_ParentGrid() 316 317 ! input : indminglob,indmaxglob : global indexes where data are required for the interpolation 318 ! output : indminglob2,indmaxglob2 : global indexes restricted to the bounds of the current processor 319 ! output : member is false if the current processor does not need to send data 320 321 call Agrif_Childbounds(nbdim,lowerbound,upperbound, & 322 indminglob,indmaxglob, Agrif_Procrank, coords, & 323 indmin,indmax,member) 324 325 call Agrif_ParentGrid_to_ChildGrid() 326 327 indminglob = indmin 328 indmaxglob = indmax 329 233 330 parentarray(:,1,1) = indminglob 234 331 parentarray(:,2,1) = indmaxglob 235 332 parentarray(:,1,2) = indminglob 236 333 parentarray(:,2,2) = indmaxglob 237 indmin = indminglob238 indmax = indmaxglob334 ! indmin = indminglob 335 ! indmax = indmaxglob 239 336 member = .TRUE. 240 337 s_Parent_temp = s_Parent + (indminglob - pttab_Parent) * ds_Parent … … 246 343 if (.not.associated(tempP)) allocate(tempP) 247 344 ! 345 248 346 call Agrif_array_allocate(tempP,parentarray(:,1,1),parentarray(:,2,1),nbdim) 249 347 call Agrif_var_set_array_tozero(tempP,nbdim) … … 286 384 parentarray(6,1,2),parentarray(6,2,2),.TRUE.,nb,ndir) 287 385 end select 386 288 387 ! 289 388 call Agrif_ParentGrid_to_ChildGrid() … … 298 397 tab3(:,3) = indmin(:) 299 398 tab3(:,4) = indmax(:) 399 tab5(:,1) = indminglob3(:) 400 tab5(:,2) = indmaxglob3(:) 300 401 ! 301 402 call MPI_ALLGATHER(tab3,4*nbdim,MPI_INTEGER,tab4,4*nbdim,MPI_INTEGER,Agrif_mpi_comm,code) 302 403 call MPI_ALLGATHER(tab5,2*nbdim,MPI_INTEGER,tab6,2*nbdim,MPI_INTEGER,Agrif_mpi_comm,code) 303 404 if (.not.associated(tempPextend)) allocate(tempPextend) 304 405 … … 311 412 enddo 312 413 414 do k=0,Agrif_Nbprocs-1 415 do j=1,2 416 do i=1,nbdim 417 tab5t(i,k,j) = tab6(i,j,k) 418 enddo 419 enddo 420 enddo 421 313 422 memberin1(1) = memberin 314 423 call MPI_ALLGATHER(memberin1,1,MPI_LOGICAL,memberinall,1,MPI_LOGICAL,Agrif_mpi_comm,code) … … 319 428 sendtoproc1,recvfromproc1, & 320 429 tab4t(:,:,5),tab4t(:,:,6), & 321 tab4t(:,:,7),tab4t(:,:,8) ) 430 tab4t(:,:,7),tab4t(:,:,8), & 431 tab5t(:,:,1),tab5t(:,:,2)) 322 432 endif 323 433 … … 333 443 child%list_interp,pttab,petab, & 334 444 pttab_Child,pttab_Parent,indmin,indmax, & 445 indmin_required_p, indmax_required_p, & 335 446 indminglob,indmaxglob, & 336 447 pttruetab,cetruetab, & … … 345 456 endif 346 457 ! 458 347 459 if (memberin) then 348 460 ! 349 461 if (.not.associated(tempC)) allocate(tempC) 350 462 ! 463 351 464 call Agrif_array_allocate(tempC,pttruetab,cetruetab,nbdim) 465 352 466 ! 353 467 ! Special values on the parent grid … … 357 471 ! 358 472 if (.not.associated(parentvalues)) allocate(parentvalues) 359 ! 473 !t 474 360 475 call Agrif_array_allocate(parentvalues,indmin,indmax,nbdim) 361 476 call Agrif_var_full_copy_array(parentvalues,tempPextend,nbdim) 362 477 ! 363 call Agrif_CheckMasknD(tempPextend,parentvalues, & 364 indmin(1:nbdim),indmax(1:nbdim), & 365 indmin(1:nbdim),indmax(1:nbdim), & 478 call Agrif_CheckMasknD(tempPextend,parentvalues, & 479 indmin(1:nbdim),indmax(1:nbdim), & 480 indmin(1:nbdim),indmax(1:nbdim), & 481 indmin_required_p(1:nbdim),indmax_required_p(1:nbdim), & 366 482 noraftab(1:nbdim),nbdim) 367 483 ! … … 391 507 ds_Child(1:2), ds_Parent(1:2) ) 392 508 case(3) 393 call Agrif_Interp_3D_recursive( type_interp(1:3), & 394 tempPextend % array3, & 395 tempC % array3, & 396 indmin(1:3), indmax(1:3), & 397 pttruetab(1:3), cetruetab(1:3), & 398 s_Child_temp(1:3), s_Parent_temp(1:3), & 509 s_Parent_temp_p = s_Parent + (indmin_required_p - pttab_Parent) * ds_Parent 510 call Agrif_Interp_3D_recursive( type_interp(1:3), & 511 tempPextend % array3( & 512 indmin_required_p(1):indmax_required_p(1), & 513 indmin_required_p(2):indmax_required_p(2), & 514 indmin_required_p(3):indmax_required_p(3)), & 515 tempC % array3, & 516 indmin_required_p(1:3), indmax_required_p(1:3), & 517 pttruetab(1:3), cetruetab(1:3), & 518 s_Child_temp(1:3), s_Parent_temp_p(1:3), & 399 519 ds_Child(1:3), ds_Parent(1:3) ) 520 400 521 case(4) 401 call Agrif_Interp_4D_recursive( type_interp(1:4), & 402 tempPextend % array4, & 403 tempC % array4, & 404 indmin(1:4), indmax(1:4), & 405 pttruetab(1:4), cetruetab(1:4), & 406 s_Child_temp(1:4), s_Parent_temp(1:4), & 522 s_Parent_temp_p = s_Parent + (indmin_required_p - pttab_Parent) * ds_Parent 523 call Agrif_Interp_4D_recursive( type_interp(1:4), & 524 tempPextend % array4( & 525 indmin_required_p(1):indmax_required_p(1), & 526 indmin_required_p(2):indmax_required_p(2), & 527 indmin_required_p(3):indmax_required_p(3), & 528 indmin_required_p(4):indmax_required_p(4)), & 529 tempC % array4, & 530 indmin_required_p(1:4), indmax_required_p(1:4), & 531 pttruetab(1:4), cetruetab(1:4), & 532 s_Child_temp(1:4), s_Parent_temp_p(1:4), & 407 533 ds_Child(1:4), ds_Parent(1:4) ) 408 534 case(5) … … 595 721 else ! .not.to_restore 596 722 ! 723 597 724 if (memberin) then 598 725 ! … … 715 842 endif 716 843 844 717 845 call Agrif_array_deallocate(tempPextend,nbdim) 718 846 call Agrif_array_deallocate(tempC,nbdim) … … 736 864 !--------------------------------------------------------------------------------------------------- 737 865 subroutine Agrif_Parentbounds ( type_interp, nbdim, indmin, indmax, & 866 indmin_required,indmax_required, & 738 867 s_Parent_temp, s_Child_temp, & 739 868 s_Child, ds_Child, & … … 745 874 INTEGER, intent(in) :: nbdim 746 875 INTEGER, DIMENSION(nbdim), intent(out) :: indmin, indmax 747 REAL, DIMENSION(nbdim), intent(out) :: s_Parent_temp, s_child_temp 748 REAL, DIMENSION(nbdim), intent(in) :: s_Child, ds_child 749 REAL, DIMENSION(nbdim), intent(in) :: s_Parent,ds_Parent 876 INTEGER, DIMENSION(nbdim), intent(out) :: indmin_required, indmax_required 877 REAL(kind=8), DIMENSION(nbdim), intent(out) :: s_Parent_temp, s_child_temp 878 REAL(kind=8), DIMENSION(nbdim), intent(in) :: s_Child, ds_child 879 REAL(kind=8), DIMENSION(nbdim), intent(in) :: s_Parent,ds_Parent 750 880 INTEGER, DIMENSION(nbdim), intent(in) :: pttruetab, cetruetab 751 881 INTEGER, DIMENSION(nbdim), intent(in) :: pttab_Child, pttab_Parent … … 753 883 INTEGER, DIMENSION(nbdim), intent(in) :: coords 754 884 ! 885 REAL(kind=8) :: xpmin, xpmax 886 INTEGER :: coeffraf 755 887 INTEGER :: i 756 REAL ,DIMENSION(nbdim) :: dim_newmin, dim_newmax888 REAL(kind=8),DIMENSION(nbdim) :: dim_newmin, dim_newmax 757 889 ! 758 890 dim_newmin = s_Child + (pttruetab - pttab_Child) * ds_Child … … 763 895 indmin(i) = pttab_Parent(i) + agrif_int((dim_newmin(i)-s_Parent(i))/ds_Parent(i)) 764 896 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) 765 902 ! 766 903 ! Necessary for the Quadratic interpolation 767 904 ! 905 768 906 if ( (pttruetab(i) == cetruetab(i)) .and. (posvar(i) == 1) ) then 907 if (Agrif_UseSpecialValue) then 908 indmin(i) = indmin(i)-MaxSearch 909 indmax(i) = indmax(i)+MaxSearch 910 endif 769 911 elseif ( coords(i) == 0 ) then ! (interptab == 'N') 770 912 elseif ( (type_interp(i) == Agrif_ppm) .or. & … … 772 914 (type_interp(i) == Agrif_ppm_lim) .or. & 773 915 (type_interp(i) == Agrif_weno) ) then 774 indmin(i) = indmin(i) - 2 775 indmax(i) = indmax(i) + 2 776 916 917 if ((mod(coeffraf,2) == 0).AND.(posvar(i)==2)) then 918 919 xpmax = s_Parent(i)+(indmax(i)-pttab_Parent(i))*ds_Parent(i) 920 if (xpmax > dim_newmax(i)+ds_Child(i)) then 921 indmax(i) = indmax(i) + 1 922 else 923 indmax(i) = indmax(i) + 2 924 endif 925 926 xpmin = s_Parent(i)+(indmin(i)-pttab_Parent(i))*ds_Parent(i) 927 if (xpmin < dim_newmin(i)-ds_Child(i)) then 928 indmin(i) = indmin(i) - 1 929 else 930 indmin(i) = indmin(i) - 2 931 endif 932 933 else 934 indmin(i) = indmin(i) - 2 935 indmax(i) = indmax(i) + 2 936 endif 937 938 indmin_required(i) = indmin(i) 939 indmax_required(i) = indmax(i) 940 777 941 if (Agrif_UseSpecialValue) then 778 942 indmin(i) = indmin(i)-MaxSearch 779 943 indmax(i) = indmax(i)+MaxSearch 780 944 endif 781 945 elseif (type_interp(i) == Agrif_linearconservlim) then 946 947 if ((mod(coeffraf,2) == 0).AND.(posvar(i)==2)) then 948 949 xpmax = s_Parent(i)+(indmax(i)-pttab_Parent(i))*ds_Parent(i) 950 if (xpmax > dim_newmax(i)+ds_Child(i)) then 951 indmax(i) = indmax(i) 952 else 953 indmax(i) = indmax(i) + 1 954 endif 955 956 xpmin = s_Parent(i)+(indmin(i)-pttab_Parent(i))*ds_Parent(i) 957 if (xpmin < dim_newmin(i)-ds_Child(i)) then 958 indmin(i) = indmin(i) 959 else 960 indmin(i) = indmin(i) - 1 961 endif 962 963 else 964 indmin(i) = indmin(i) - 1 965 indmax(i) = indmax(i) + 1 966 endif 967 968 indmin_required(i) = indmin(i) 969 indmax_required(i) = indmax(i) 970 971 if (Agrif_UseSpecialValue) then 972 indmin(i) = indmin(i)-MaxSearch 973 indmax(i) = indmax(i)+MaxSearch 974 endif 975 782 976 elseif ( (type_interp(i) /= Agrif_constant) .and. & 783 977 (type_interp(i) /= Agrif_linear) ) then 784 978 indmin(i) = indmin(i) - 1 785 979 indmax(i) = indmax(i) + 1 980 981 indmin_required(i) = indmin(i) 982 indmax_required(i) = indmax(i) 786 983 787 984 if (Agrif_UseSpecialValue) then … … 789 986 indmax(i) = indmax(i)+MaxSearch 790 987 endif 791 792 988 elseif ( (type_interp(i) == Agrif_constant) .or. & 793 989 (type_interp(i) == Agrif_linear) ) then 990 indmin_required(i) = indmin(i) 991 indmax_required(i) = indmax(i) 794 992 if (Agrif_UseSpecialValue) then 795 993 indmin(i) = indmin(i)-MaxSearch 796 994 indmax(i) = indmax(i)+MaxSearch 797 995 endif 798 799 996 endif 997 800 998 ! 801 999 enddo … … 822 1020 integer, intent(in) :: indmin, indmax 823 1021 integer, intent(in) :: pttab_child, petab_child 824 real , intent(in) :: s_child, s_parent825 real , intent(in) :: ds_child, ds_parent1022 real(kind=8), intent(in) :: s_child, s_parent 1023 real(kind=8), intent(in) :: ds_child, ds_parent 826 1024 real, dimension( & 827 1025 indmin:indmax & … … 857 1055 integer, dimension(2), intent(in) :: indmin, indmax 858 1056 integer, dimension(2), intent(in) :: pttab_child, petab_child 859 real , dimension(2), intent(in) :: s_child, s_parent860 real , dimension(2), intent(in) :: ds_child, ds_parent1057 real(kind=8), dimension(2), intent(in) :: s_child, s_parent 1058 real(kind=8), dimension(2), intent(in) :: ds_child, ds_parent 861 1059 real, dimension( & 862 1060 indmin(1):indmax(1), & … … 875 1073 indmin(2):indmax(2), & 876 1074 pttab_child(1):petab_child(1)) :: tabtemp_trsp 877 integer :: i, j, coeffraf 1075 integer :: i, j, coeffraf, locind_child_left, ideb 878 1076 !--------------------------------------------------------------------------------------------------- 879 1077 ! … … 900 1098 s_parent(1),s_child(1),ds_parent(1),ds_child(1),1) 901 1099 !---CDIR NEXPAND 902 call PPM1dAfterCompute(tabin,tabtemp,size(tabin),size(tabtemp),1) 1100 call PPM1dAfterCompute(tabin,tabtemp,size(tabin),size(tabtemp),1,indchildppm(:,1),tabppm(:,:,1)) 1101 else if (coeffraf == 1) then 1102 locind_child_left = indmin(1) + agrif_int((s_child(1)-s_parent(1))/ds_parent(1)) 1103 1104 do j = indmin(2), indmax(2) 1105 ideb = locind_child_left 1106 do i = pttab_child(1), petab_child(1) 1107 tabtemp(i,j) = tabin(ideb,j) 1108 ideb = ideb + 1 1109 enddo 1110 enddo 1111 903 1112 else 904 1113 do j = indmin(2),indmax(2) … … 941 1150 !---CDIR NEXPAND 942 1151 call PPM1dAfterCompute(tabtemp_trsp, tabout_trsp, & 943 size(tabtemp_trsp), size(tabout_trsp), 2) 1152 size(tabtemp_trsp), size(tabout_trsp), 2, & 1153 indchildppm(:,2),tabppm(:,:,2)) 944 1154 else 945 1155 do i = pttab_child(1), petab_child(1) … … 976 1186 integer, dimension(3), intent(in) :: indmin, indmax 977 1187 integer, dimension(3), intent(in) :: pttab_child, petab_child 978 real , dimension(3), intent(in) :: s_child, s_parent979 real , dimension(3), intent(in) :: ds_child, ds_parent1188 real(kind=8), dimension(3), intent(in) :: s_child, s_parent 1189 real(kind=8), dimension(3), intent(in) :: ds_child, ds_parent 980 1190 real, dimension( & 981 1191 indmin(1):indmax(1), & … … 991 1201 pttab_child(2):petab_child(2), & 992 1202 indmin(3):indmax(3)) :: tabtemp 993 integer :: i, j, k, coeffraf 1203 integer :: i, j, k, coeffraf,kp,kp1,kp2,kp3,kp4,kref 994 1204 integer :: locind_child_left, kdeb 1205 real(kind=8) :: ypos,globind_parent_left 1206 real(kind=8) :: deltax, invdsparent 1207 real :: t2,t3,t4,t5,t6,t7,t8 1208 integer :: locind_parent_left 1209 995 1210 ! 996 1211 coeffraf = nint ( ds_parent(1) / ds_child(1) ) … … 1051 1266 enddo 1052 1267 enddo 1268 else if (type_interp(3) == Agrif_LAGRANGE) then 1269 invdsparent = 1./ds_parent(3) 1270 ypos = s_child(3) 1271 do k=pttab_child(3), petab_child(3) 1272 locind_parent_left = indmin(3)+agrif_int((ypos - s_parent(3))/ds_parent(3)) 1273 globind_parent_left = s_parent(3) + (locind_parent_left - indmin(3))*ds_parent(3) 1274 deltax = invdsparent*(ypos-globind_parent_left) 1275 deltax = nint(coeffraf*deltax)/real(coeffraf) 1276 ypos = ypos + ds_child(3) 1277 1278 if (abs(deltax) <= 0.0001) then 1279 do j = pttab_child(2), petab_child(2) 1280 do i = pttab_child(1), petab_child(1) 1281 tabout(i,j,k) = tabtemp(i,j,locind_parent_left) 1282 enddo 1283 enddo 1284 else 1285 t2 = deltax - 2. 1286 t3 = deltax - 1. 1287 t4 = deltax + 1. 1288 1289 t5 = -(1./6.)*deltax*t2*t3 1290 t6 = 0.5*t2*t3*t4 1291 t7 = -0.5*deltax*t2*t4 1292 t8 = (1./6.)*deltax*t3*t4 1293 do j = pttab_child(2), petab_child(2) 1294 do i = pttab_child(1), petab_child(1) 1295 tabout(i,j,k) = t5*tabtemp(i,j,locind_parent_left-1) + t6*tabtemp(i,j,locind_parent_left) & 1296 +t7*tabtemp(i,j,locind_parent_left+1) + t8*tabtemp(i,j,locind_parent_left+2) 1297 enddo 1298 enddo 1299 1300 endif 1301 1302 enddo 1303 else if (type_interp(3) == Agrif_PPM) then 1304 call PPM1dPrecompute2d(1, & 1305 indmax(3)-indmin(3)+1, & 1306 petab_child(3)-pttab_child(3)+1, & 1307 s_parent(3),s_child(3),ds_parent(3),ds_child(3),1) 1308 1309 do k=pttab_child(3),petab_child(3) 1310 kref = k-pttab_child(3)+1 1311 kp=indmin(3)+indparentppm(kref,1)-1 1312 kp1 = kp + 1 1313 kp2 = kp1 + 1 1314 kp3 = kp2 + 1 1315 kp4 = kp3 + 1 1316 do j = pttab_child(2), petab_child(2) 1317 do i = pttab_child(1), petab_child(1) 1318 tabout(i,j,k) = tabppm(1,indchildppm(kref,1),1)*tabtemp(i,j,kp) + & 1319 tabppm(2,indchildppm(kref,1),1)*tabtemp(i,j,kp1) + & 1320 tabppm(3,indchildppm(kref,1),1)*tabtemp(i,j,kp2) + & 1321 tabppm(4,indchildppm(kref,1),1)*tabtemp(i,j,kp3) + & 1322 tabppm(5,indchildppm(kref,1),1)*tabtemp(i,j,kp4) 1323 enddo 1324 enddo 1325 enddo 1326 1053 1327 else 1328 1054 1329 do j = pttab_child(2), petab_child(2) 1055 1330 do i = pttab_child(1), petab_child(1) … … 1063 1338 enddo 1064 1339 enddo 1340 1065 1341 endif 1066 1342 !--------------------------------------------------------------------------------------------------- … … 1083 1359 integer, dimension(4), intent(in) :: indmin, indmax 1084 1360 integer, dimension(4), intent(in) :: pttab_child, petab_child 1085 real , dimension(4), intent(in) :: s_child, s_parent1086 real , dimension(4), intent(in) :: ds_child, ds_parent1361 real(kind=8), dimension(4), intent(in) :: s_child, s_parent 1362 real(kind=8), dimension(4), intent(in) :: ds_child, ds_parent 1087 1363 real, dimension( & 1088 1364 indmin(1):indmax(1), & … … 1102 1378 indmin(4):indmax(4)) :: tabtemp 1103 1379 integer :: i, j, k, l 1380 1381 real(kind=8) :: ypos,globind_parent_left 1382 real(kind=8) :: deltax, invdsparent 1383 real :: t2,t3,t4,t5,t6,t7,t8 1384 integer :: locind_parent_left, coeffraf 1104 1385 ! 1105 1386 do l = indmin(4), indmax(4) … … 1117 1398 enddo 1118 1399 ! 1400 if (type_interp(4) == Agrif_LAGRANGE) then 1401 coeffraf = nint(ds_parent(4)/ds_child(4)) 1402 invdsparent = 1./ds_parent(4) 1403 ypos = s_child(4) 1404 do l=pttab_child(4), petab_child(4) 1405 locind_parent_left = indmin(4)+agrif_int((ypos - s_parent(4))/ds_parent(4)) 1406 globind_parent_left = s_parent(4) + (locind_parent_left - indmin(4))*ds_parent(4) 1407 deltax = invdsparent*(ypos-globind_parent_left) 1408 deltax = nint(coeffraf*deltax)/real(coeffraf) 1409 ypos = ypos + ds_child(4) 1410 1411 if (abs(deltax) <= 0.0001) then 1412 do k = pttab_child(3), petab_child(3) 1413 do j = pttab_child(2), petab_child(2) 1414 do i = pttab_child(1), petab_child(1) 1415 tabout(i,j,k,l) = tabtemp(i,j,k,locind_parent_left) 1416 enddo 1417 enddo 1418 enddo 1419 else 1420 t2 = deltax - 2. 1421 t3 = deltax - 1. 1422 t4 = deltax + 1. 1423 1424 t5 = -(1./6.)*deltax*t2*t3 1425 t6 = 0.5*t2*t3*t4 1426 t7 = -0.5*deltax*t2*t4 1427 t8 = (1./6.)*deltax*t3*t4 1428 do k = pttab_child(3), petab_child(3) 1429 do j = pttab_child(2), petab_child(2) 1430 do i = pttab_child(1), petab_child(1) 1431 tabout(i,j,k,l) = t5*tabtemp(i,j,k,locind_parent_left-1) + t6*tabtemp(i,j,k,locind_parent_left) & 1432 +t7*tabtemp(i,j,k,locind_parent_left+1) + t8*tabtemp(i,j,k,locind_parent_left+2) 1433 enddo 1434 enddo 1435 enddo 1436 endif 1437 1438 enddo 1439 else 1119 1440 do k = pttab_child(3), petab_child(3) 1120 1441 do j = pttab_child(2), petab_child(2) … … 1130 1451 enddo 1131 1452 enddo 1453 endif 1132 1454 !--------------------------------------------------------------------------------------------------- 1133 1455 end subroutine Agrif_Interp_4D_recursive … … 1149 1471 integer, dimension(5), intent(in) :: indmin, indmax 1150 1472 integer, dimension(5), intent(in) :: pttab_child, petab_child 1151 real , dimension(5), intent(in) :: s_child, s_parent1152 real , dimension(5), intent(in) :: ds_child, ds_parent1473 real(kind=8), dimension(5), intent(in) :: s_child, s_parent 1474 real(kind=8), dimension(5), intent(in) :: ds_child, ds_parent 1153 1475 real, dimension( & 1154 1476 indmin(1):indmax(1), & … … 1222 1544 integer, dimension(6), intent(in) :: indmin, indmax 1223 1545 integer, dimension(6), intent(in) :: pttab_child, petab_child 1224 real , dimension(6), intent(in) :: s_child, s_parent1225 real , dimension(6), intent(in) :: ds_child, ds_parent1546 real(kind=8), dimension(6), intent(in) :: s_child, s_parent 1547 real(kind=8), dimension(6), intent(in) :: ds_child, ds_parent 1226 1548 real, dimension( & 1227 1549 indmin(1):indmax(1), & … … 1301 1623 REAL, DIMENSION(indmin:indmax), INTENT(IN) :: parenttab 1302 1624 REAL, DIMENSION(pttab_child:petab_child), INTENT(OUT) :: childtab 1303 REAL 1304 REAL 1625 REAL(kind=8) :: s_parent, s_child 1626 REAL(kind=8) :: ds_parent,ds_child 1305 1627 ! 1306 1628 if ( (indmin == indmax) .and. (pttab_child == petab_child) ) then … … 1371 1693 !--------------------------------------------------------------------------------------------------- 1372 1694 function Agrif_Find_list_interp ( list_interp, pttab, petab, pttab_Child, pttab_Parent, & 1373 nbdim, indmin, indmax, indminglob, indmaxglob, & 1695 nbdim, indmin, indmax, indmin_required_p, indmax_required_p, & 1696 indminglob, indmaxglob, & 1374 1697 pttruetab, cetruetab, memberin & 1375 1698 #if defined AGRIF_MPI … … 1382 1705 integer, intent(in) :: nbdim 1383 1706 integer, dimension(nbdim), intent(in) :: pttab, petab, pttab_Child, pttab_Parent 1384 integer, dimension(nbdim), intent(out) :: indmin, indmax 1707 integer, dimension(nbdim), intent(out) :: indmin, indmax, indmin_required_p, indmax_required_p 1385 1708 integer, dimension(nbdim), intent(out) :: indminglob, indmaxglob 1386 1709 integer, dimension(nbdim), intent(out) :: pttruetab, cetruetab … … 1421 1744 indmin = pil % indmin(1:nbdim) 1422 1745 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) 1423 1748 1424 1749 pttruetab = pil % pttruetab(1:nbdim) … … 1452 1777 !--------------------------------------------------------------------------------------------------- 1453 1778 subroutine Agrif_AddTo_list_interp ( list_interp, pttab, petab, pttab_Child, pttab_Parent, & 1454 indmin, indmax, indminglob, indmaxglob, & 1779 indmin, indmax, indmin_required_p, indmax_required_p, & 1780 indminglob, indmaxglob, & 1455 1781 pttruetab, cetruetab, & 1456 1782 memberin, nbdim & … … 1466 1792 integer :: nbdim 1467 1793 integer, dimension(nbdim) :: pttab, petab, pttab_Child, pttab_Parent 1468 integer, dimension(nbdim) :: indmin,indmax 1794 integer, dimension(nbdim) :: indmin,indmax, indmin_required_p, indmax_required_p 1469 1795 integer, dimension(nbdim) :: indminglob, indmaxglob 1470 1796 integer, dimension(nbdim) :: pttruetab, cetruetab … … 1495 1821 pil % indmin(1:nbdim) = indmin(1:nbdim) 1496 1822 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) 1497 1826 1498 1827 pil % memberin = memberin -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modinterpbasic.F90
r5656 r10087 41 41 integer, dimension(:), allocatable :: indparentppm_1d, indchildppm_1d 42 42 ! 43 43 44 private :: Agrif_limiter_vanleer 44 45 ! … … 56 57 integer, intent(in) :: np !< Length of input array 57 58 integer, intent(in) :: nc !< Length of output array 58 real , intent(in) :: s_parent !< Parent grid position (s_root = 0)59 real , intent(in) :: s_child !< Child grid position (s_root = 0)60 real , intent(in) :: ds_parent !< Parent grid dx (ds_root = 1)61 real , intent(in) :: ds_child !< Child grid dx (ds_root = 1)59 real(kind=8), intent(in) :: s_parent !< Parent grid position (s_root = 0) 60 real(kind=8), intent(in) :: s_child !< Child grid position (s_root = 0) 61 real(kind=8), intent(in) :: ds_parent !< Parent grid dx (ds_root = 1) 62 real(kind=8), intent(in) :: ds_child !< Child grid dx (ds_root = 1) 62 63 ! 63 64 integer :: i, coeffraf, locind_parent_left 64 real :: globind_parent_left, globind_parent_right65 real :: invds, invds2, ypos, ypos2, diff65 real(kind=8) :: globind_parent_left, globind_parent_right 66 real(kind=8) :: invds, invds2, ypos, ypos2, diff 66 67 ! 67 68 coeffraf = nint(ds_parent/ds_child) … … 92 93 ! 93 94 diff = globind_parent_right - ypos2 95 ! quick fix for roundoff error 96 diff=nint(diff*coeffraf)/real(coeffraf) 97 94 98 y(i) = (diff*x(locind_parent_left) + (1.-diff)*x(locind_parent_left+1)) 99 95 100 ypos2 = ypos2 + invds2 96 101 ! … … 104 109 else 105 110 globind_parent_left = s_parent + (locind_parent_left - 1)*ds_parent 106 y(nc) = ((globind_parent_left + ds_parent - ypos)*x(locind_parent_left) & 107 + (ypos - globind_parent_left)*x(locind_parent_left+1))*invds 108 endif 111 diff=(globind_parent_left + ds_parent - ypos)*invds 112 113 ! quick fix for roundoff error 114 diff=nint(diff*coeffraf)/real(coeffraf) 115 ! y(nc) = ((globind_parent_left + ds_parent - ypos)*x(locind_parent_left) & 116 ! + (ypos - globind_parent_left)*x(locind_parent_left+1))*invds 117 y(nc) = (diff*x(locind_parent_left) + (1.-diff)*x(locind_parent_left+1)) 118 endif 119 109 120 !--------------------------------------------------------------------------------------------------- 110 121 end subroutine Agrif_basicinterp_linear1D … … 120 131 !--------------------------------------------------------------------------------------------------- 121 132 integer, intent(in) :: np,nc,np2 122 real , intent(in) :: s_parent, s_child123 real , intent(in) :: ds_parent, ds_child133 real(kind=8), intent(in) :: s_parent, s_child 134 real(kind=8), intent(in) :: ds_parent, ds_child 124 135 integer, intent(in) :: dir 125 136 ! … … 127 138 integer, dimension(:,:), allocatable :: indparent_tmp 128 139 real, dimension(:,:), allocatable :: coeffparent_tmp 129 real :: ypos,globind_parent_left,globind_parent_right130 real :: invds, invds2, invds3131 real :: ypos2,diff140 real(kind=8) :: ypos,globind_parent_left,globind_parent_right 141 real(kind=8) :: invds, invds2, invds3 142 real(kind=8) :: ypos2,diff 132 143 ! 133 144 coeffraf = nint(ds_parent/ds_child) … … 164 175 if (ypos2 > globind_parent_right) then 165 176 locind_parent_left = locind_parent_left + 1 166 globind_parent_right = globind_parent_right + 1. 177 globind_parent_right = globind_parent_right + 1.d0 167 178 ypos2 = ypos*invds+(i-1)*invds2 168 179 endif … … 239 250 real, dimension(np), intent(in) :: x 240 251 real, dimension(nc), intent(out) :: y 241 real , intent(in) :: s_parent, s_child242 real , intent(in) :: ds_parent, ds_child252 real(kind=8), intent(in) :: s_parent, s_child 253 real(kind=8), intent(in) :: ds_parent, ds_child 243 254 ! 244 255 integer :: i, coeffraf, locind_parent_left 245 real :: ypos,globind_parent_left246 real :: deltax, invdsparent256 real(kind=8) :: ypos,globind_parent_left 257 real(kind=8) :: deltax, invdsparent 247 258 real :: t2,t3,t4,t5,t6,t7,t8 248 259 ! … … 304 315 real, dimension(np), intent(in) :: x 305 316 real, dimension(nc), intent(out) :: y 306 real , intent(in) :: s_parent, s_child307 real , intent(in) :: ds_parent, ds_child317 real(kind=8), intent(in) :: s_parent, s_child 318 real(kind=8), intent(in) :: ds_parent, ds_child 308 319 ! 309 320 integer :: i, coeffraf, locind_parent 310 real :: ypos321 real(kind=8) :: ypos 311 322 ! 312 323 coeffraf = nint(ds_parent/ds_child) … … 342 353 real, dimension(np), intent(in) :: x 343 354 real, dimension(nc), intent(out) :: y 344 real , intent(in) :: s_parent, s_child345 real , intent(in) :: ds_parent, ds_child355 real(kind=8), intent(in) :: s_parent, s_child 356 real(kind=8), intent(in) :: ds_parent, ds_child 346 357 ! 347 358 real, dimension(:), allocatable :: ytemp 348 359 integer :: i,coeffraf,locind_parent_left,locind_parent_last 349 real :: ypos,xdiffmod,xpmin,xpmax,slope360 real(kind=8) :: ypos,xdiffmod,xpmin,xpmax,slope 350 361 integer :: i1,i2,ii 351 362 integer :: diffmod … … 429 440 real, dimension(np), intent(in) :: x 430 441 real, dimension(nc), intent(out) :: y 431 real , intent(in) :: s_parent, s_child432 real , intent(in) :: ds_parent, ds_child442 real(kind=8), intent(in) :: s_parent, s_child 443 real(kind=8), intent(in) :: ds_parent, ds_child 433 444 ! 434 445 real, dimension(:), allocatable :: ytemp 435 446 integer :: i,coeffraf,locind_parent_left,locind_parent_last 436 real :: ypos,xdiffmod,xpmin,xpmax,slope447 real(kind=8) :: ypos,xdiffmod,xpmin,xpmax,slope 437 448 integer :: i1,i2,ii 438 449 integer :: diffmod … … 524 535 real, dimension(np), intent(in) :: x 525 536 real, dimension(nc), intent(out) :: y 526 real , intent(in) :: s_parent, s_child527 real , intent(in) :: ds_parent, ds_child537 real(kind=8), intent(in) :: s_parent, s_child 538 real(kind=8), intent(in) :: ds_parent, ds_child 528 539 ! 529 540 integer :: i,coeffraf,locind_parent_left,locind_parent_last 530 541 integer :: iparent,ipos,pos,nmin,nmax 531 real :: ypos542 real(kind=8) :: ypos 532 543 integer :: i1,jj 533 real :: xpmin,a 544 real(kind=8) :: xpmin 545 real :: a 534 546 ! 535 547 real, dimension(np) :: xl,delta,a6,slope … … 646 658 !--------------------------------------------------------------------------------------------------- 647 659 integer, intent(in) :: np2, np, nc 648 real , intent(in) :: s_parent, s_child649 real , intent(in) :: ds_parent, ds_child660 real(kind=8), intent(in) :: s_parent, s_child 661 real(kind=8), intent(in) :: ds_parent, ds_child 650 662 integer, intent(in) :: dir 651 663 ! … … 655 667 integer :: iparent,ipos,pos 656 668 real :: ypos 657 integer :: i1,jj 658 real :: xpmin,a 669 integer :: i1,jj,k,l,j 670 real(kind=8) :: xpmin 671 real :: a 659 672 ! 660 673 integer :: diffmod … … 738 751 enddo 739 752 ! 740 do i = 1,np2 741 indparentppm(1+(i-1)*nc:i*nc,dir) = indparentppm_1d(1:nc) + (i-1)*np 742 indchildppm (1+(i-1)*nc:i*nc,dir) = indchildppm_1d (1:nc) 753 754 k=1 755 l=0 756 do i=1,np2 757 do j=1,nc 758 indchildppm(k,dir) = indchildppm_1d(j) 759 indparentppm(k,dir) = indparentppm_1d(j) + l 760 k=k+1 761 enddo 762 l=l+np 743 763 enddo 744 764 !--------------------------------------------------------------------------------------------------- … … 746 766 !=================================================================================================== 747 767 ! 748 !=================================================================================================== 749 !subroutine PPM1dPrecompute(np,nc,& 750 ! s_parent,s_child,ds_parent,ds_child) 751 !! 752 !!CC Description: 753 !!CC subroutine to compute coefficient and index for a 1D interpolation 754 !!CC using piecewise parabolic method 755 !!C Method: 756 !! 757 !! Declarations: 758 !! 759 ! Implicit none 760 !! 761 !! Arguments 762 ! Integer :: np,nc 763 !! Real, Dimension(:),Allocatable :: ytemp 764 ! Real :: s_parent,s_child,ds_parent,ds_child 765 !! 766 !! Local scalars 767 ! Integer :: i,coeffraf,locind_parent_left,locind_parent_last 768 ! Integer :: iparent,ipos,pos,nmin,nmax 769 ! Real :: ypos 770 ! integer :: i1,jj 771 ! Real :: xpmin,a 772 !! 773 ! Real :: xrmin,xrmax,am3,s2,s1 774 ! Real, Dimension(np) :: xl,delta,a6,slope 775 !! Real, Dimension(:),Allocatable :: diff,diff2,diff3 776 ! INTEGER :: diffmod 777 ! REAL :: invcoeffraf 778 !! 779 ! coeffraf = nint(ds_parent/ds_child) 780 !! 781 ! If (coeffraf == 1) Then 782 ! return 783 ! End If 784 ! invcoeffraf = ds_child/ds_parent 785 !! 786 ! 787 ! if (.not.allocated(indparentppm)) then 788 ! allocate(indparentppm(-2*coeffraf:nc+2*coeffraf,1),& 789 ! indchildppm(-2*coeffraf:nc+2*coeffraf,1)) 790 ! else 791 ! if (size(indparentppm,1)<nc+4*coeffraf+1) then 792 ! deallocate(indparentppm,indchildppm) 793 ! allocate(indparentppm(-2*coeffraf:nc+2*coeffraf,1),& 794 ! indchildppm(-2*coeffraf:nc+2*coeffraf,1)) 795 ! endif 796 ! endif 797 ! 798 ! ypos = s_child 799 !! 800 ! locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent) 801 ! locind_parent_last = 1 +& 802 ! agrif_ceiling((ypos +(nc - 1)& 803 ! *ds_child - s_parent)/ds_parent) 804 !! 805 ! xpmin = s_parent + (locind_parent_left-1)*ds_parent 806 ! i1 = 1+agrif_int((xpmin-s_child)/ds_child) 807 !! 808 !! 809 ! 810 ! Do i=1,coeffraf 811 ! tabdiff2(i)=(real(i)-0.5)*invcoeffraf 812 ! EndDo 813 ! 814 ! a = invcoeffraf**2 815 ! tabdiff3(1) = (1./3.)*a 816 ! a=2.*a 817 !!CDIR ALTCODE 818 !!!!CDIR SHORTLOOP 819 ! Do i=2,coeffraf 820 ! tabdiff3(i) = tabdiff3(i-1)+(real(i)-1)*a 821 ! EndDo 822 ! 823 !!CDIR ALTCODE 824 !!!!CDIR SHORTLOOP 825 ! Do i=1,coeffraf 826 ! tabppm(1,i,1) = 0.08333333333333*(-1.+4*tabdiff2(i)-3*tabdiff3(i)) 827 ! tabppm(2,i,1) = 0.08333333333333*& 828 ! (7.-26.*tabdiff2(i)+18.*tabdiff3(i)) 829 ! tabppm(3,i,1) =0.08333333333333*(7.+30*tabdiff2(i)-30*tabdiff3(i)) 830 ! tabppm(4,i,1) = 0.08333333333333*& 831 ! (-1.-10.*tabdiff2(i)+18.*tabdiff3(i)) 832 ! tabppm(5,i,1) = 0.08333333333333*(2*tabdiff2(i)-3*tabdiff3(i)) 833 ! End Do 834 !! 835 !! 836 ! diffmod = 0 837 ! IF (mod(coeffraf,2) == 0) diffmod = 1 838 !! 839 ! ipos = i1 840 !! 841 ! Do iparent = locind_parent_left,locind_parent_last 842 ! pos=1 843 !!CDIR ALTCODE 844 !!CDIR SHORTLOOP 845 ! Do jj = ipos - coeffraf/2+diffmod,ipos + coeffraf/2 846 ! indparentppm(jj,1) = iparent-2 847 ! indchildppm(jj,1) = pos 848 ! pos = pos+1 849 ! End do 850 ! ipos = ipos + coeffraf 851 !! 852 ! End do 853 ! 854 ! Return 855 ! End subroutine ppm1dprecompute 768 856 769 !=================================================================================================== 857 770 ! … … 863 776 ! Use precomputed coefficient and index. 864 777 !--------------------------------------------------------------------------------------------------- 865 subroutine PPM1dAfterCompute ( x, y, np, nc, dir ) 866 !--------------------------------------------------------------------------------------------------- 778 subroutine PPM1dAfterCompute ( x, y, np, nc, dir, indchildppmloc, tabppmloc ) 779 !--------------------------------------------------------------------------------------------------- 780 integer, intent(in) :: np, nc 867 781 real, dimension(np), intent(in) :: x 868 782 real, dimension(nc), intent(out) :: y 869 integer, intent(in) :: np, nc870 783 integer, intent(in) :: dir 871 ! 872 integer :: i 873 ! 784 integer, dimension(1:),intent(in) :: indchildppmloc 785 real, dimension(1:,1:),intent(in) :: tabppmloc 786 ! 787 integer :: i,j,jp1,jp2,jp3,jp4,k 788 789 874 790 do i = 1,nc 875 y(i) = tabppm(1,indchildppm(i,dir),dir) * x(indparentppm(i,dir) ) + & 876 tabppm(2,indchildppm(i,dir),dir) * x(indparentppm(i,dir)+1) + & 877 tabppm(3,indchildppm(i,dir),dir) * x(indparentppm(i,dir)+2) + & 878 tabppm(4,indchildppm(i,dir),dir) * x(indparentppm(i,dir)+3) + & 879 tabppm(5,indchildppm(i,dir),dir) * x(indparentppm(i,dir)+4) 880 enddo 791 j = indparentppm(i,dir) 792 jp1=j+1 793 jp2=jp1+1 794 jp3=jp2+1 795 jp4=jp3+1 796 y(i) = tabppmloc(1,indchildppmloc(i)) * x(j) + & 797 tabppmloc(2,indchildppmloc(i)) * x(jp1) + & 798 tabppmloc(3,indchildppmloc(i)) * x(jp2) + & 799 tabppmloc(4,indchildppmloc(i)) * x(jp3) + & 800 tabppmloc(5,indchildppmloc(i)) * x(jp4) 801 enddo 802 881 803 !--------------------------------------------------------------------------------------------------- 882 804 end subroutine PPM1dAfterCompute 805 883 806 !=================================================================================================== 884 807 ! … … 1069 992 real, dimension(np), intent(in) :: x 1070 993 real, dimension(nc), intent(out) :: y 1071 real , intent(in) :: s_parent, s_child1072 real , intent(in) :: ds_parent, ds_child994 real(kind=8), intent(in) :: s_parent, s_child 995 real(kind=8), intent(in) :: ds_parent, ds_child 1073 996 ! 1074 997 real, dimension(:), allocatable :: ytemp 1075 998 integer :: i,coeffraf,locind_parent_left,locind_parent_last 1076 999 integer :: iparent,ipos,pos,nmin,nmax 1077 real :: ypos1000 real(kind=8) :: ypos 1078 1001 integer :: i1,jj 1079 real :: xpmin1002 real(kind=8) :: xpmin 1080 1003 ! 1081 1004 real, dimension(np) :: slope … … 1166 1089 real, dimension(np), intent(in) :: x 1167 1090 real, dimension(nc), intent(out) :: y 1168 real , intent(in) :: s_parent, s_child1169 real , intent(in) :: ds_parent, ds_child1091 real(kind=8), intent(in) :: s_parent, s_child 1092 real(kind=8), intent(in) :: ds_parent, ds_child 1170 1093 ! 1171 1094 integer :: i,coeffraf,locind_parent_left,locind_parent_last 1172 1095 integer :: ipos, pos 1173 real :: ypos,xi1096 real(kind=8) :: ypos,xi 1174 1097 integer :: i1,jj 1175 real :: xpmin1098 real(kind=8) :: xpmin 1176 1099 ! 1177 1100 real, dimension(:), allocatable :: ytemp … … 1276 1199 Real, Dimension(nc) :: y 1277 1200 Real, Dimension(:),Allocatable :: ytemp 1278 Real 1201 Real(kind=8) :: s_parent,s_child,ds_parent,ds_child 1279 1202 ! 1280 1203 ! Local scalars 1281 1204 Integer :: i,coeffraf,locind_parent_left,locind_parent_last 1282 1205 Integer :: iparent,ipos,pos,nmin,nmax 1283 Real :: ypos1206 Real(kind=8) :: ypos 1284 1207 integer :: i1,jj 1285 Real :: xpmin,cavg,a,b 1208 Real(kind=8) :: xpmin 1209 real :: cavg,a,b 1286 1210 ! 1287 1211 Real :: xrmin,xrmax,am3,s2,s1 -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modlinktomodel.F90
r5656 r10087 80 80 ! Agrif_Curgrid % spaceref(1) 81 81 !=================================================================================================== 82 ! function Agrif_Parent_Irhox83 ! modify by conv. To use : var = Agrif_Parent_IRhox()84 ! Agrif_Curgrid % parent % spaceref(1)85 !===================================================================================================86 82 ! function Agrif_Rhoy 87 83 ! modify by conv. To use : var = Agrif_Rhoy() … … 96 92 ! Agrif_Curgrid % spaceref(2) 97 93 !=================================================================================================== 98 ! function Agrif_Parent_Irhoy 99 ! modify by conv. To use : var = Agrif_Parent_IRhoy() 100 ! Agrif_Curgrid % parent % spaceref(2) 94 95 101 96 !=================================================================================================== 102 97 ! function Agrif_Rhoz … … 111 106 ! modify by conv. To use : var = Agrif_Parent_IRhoz() 112 107 ! Agrif_Curgrid % spaceref(3) 113 !=================================================================================================== 114 ! function Agrif_Parent_Irhoz 115 ! modify by conv. To use : var = Agrif_Parent_IRhoz() 116 ! Agrif_Curgrid % parent % spaceref(3) 108 117 109 !=================================================================================================== 118 110 ! function Agrif_NearCommonBorderX -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modmask.F90
r5656 r10087 40 40 !! when this one is equal to Agrif_SpecialValue. 41 41 !--------------------------------------------------------------------------------------------------- 42 subroutine Agrif_CheckMasknD ( tempP, parent, pbtab, petab, ppbtab, ppetab, noraftab, nbdim ) 42 subroutine Agrif_CheckMasknD ( tempP, parent, pbtab, petab, ppbtab, ppetab, & 43 pbtab_required, petab_required, noraftab, nbdim ) 43 44 !--------------------------------------------------------------------------------------------------- 44 45 type(Agrif_Variable), pointer :: tempP !< Part of the parent grid used for the interpolation of the child grid … … 46 47 integer, dimension(nbdim) :: pbtab !< limits of the parent grid used 47 48 integer, dimension(nbdim) :: petab !< interpolation of the child grid 48 integer, dimension(nbdim) :: ppbtab, ppetab 49 integer, dimension(nbdim) :: ppbtab, ppetab, pbtab_required, petab_required 49 50 logical, dimension(nbdim) :: noraftab 50 51 integer :: nbdim 51 52 ! 52 integer :: i0,j0,k0,l0,m0,n0 53 integer :: i0,j0,k0,l0,m0,n0,ll,kk 54 integer,dimension(:,:),allocatable :: trytoreplace 55 integer :: ilook, Nbvals 56 real :: xold 53 57 ! 54 58 select case (nbdim) … … 77 81 parent%array3(ppbtab(1),ppbtab(2),ppbtab(3)), & 78 82 ppbtab,ppetab,noraftab,MaxSearch,Agrif_SpecialValue) 79 80 ! Call CalculNewValTempP((/i0,j0,k0/),81 ! & tempP,parent,82 ! & ppbtab,ppetab,83 ! & noraftab,nbdim)84 85 83 endif 86 84 enddo … … 88 86 enddo 89 87 case (4) 90 do l0 = pbtab(4),petab(4) 91 do k0 = pbtab(3),petab(3) 92 do j0 = pbtab(2),petab(2) 93 do i0 = pbtab(1),petab(1) 88 89 if (noraftab(1).AND.noraftab(2)) then 90 allocate(trytoreplace(pbtab_required(3):petab_required(3),pbtab_required(4):petab_required(4))) 91 trytoreplace = -1 92 i0 = pbtab_required(1) 93 j0 = pbtab_required(2) 94 do l0 = pbtab_required(4),petab_required(4) 95 do k0 = pbtab_required(3),petab_required(3) 94 96 if (tempP%array4(i0,j0,k0,l0) == Agrif_SpecialValue) then 95 97 call CalculNewValTempP4D((/i0,j0,k0,l0/), & 96 98 tempP%array4(ppbtab(1),ppbtab(2),ppbtab(3),ppbtab(4)), & 97 99 parent%array4(ppbtab(1),ppbtab(2),ppbtab(3),ppbtab(4)), & 98 ppbtab,ppetab,noraftab,MaxSearch,Agrif_SpecialValue) 99 endif 100 enddo 101 enddo 102 enddo 103 enddo 100 ppbtab,ppetab,noraftab,MaxSearch,Agrif_SpecialValue, & 101 trytoreplace(k0,l0)) 102 endif 103 enddo 104 enddo 105 106 do l0 = pbtab_required(4),petab_required(4) 107 do k0 = pbtab_required(3),petab_required(3) 108 if (trytoreplace(k0,l0) /= -1) then 109 do j0 = pbtab_required(2),petab_required(2) 110 do i0 = pbtab_required(1),petab_required(1) 111 112 if (tempP%array4(i0,j0,k0,l0) == Agrif_SpecialValue) then 113 tempP%array4(i0,j0,k0,l0) = 0. 114 Nbvals = 0 115 do ll=max(l0-trytoreplace(k0,l0),ppbtab(4)),min(l0+trytoreplace(k0,l0),ppetab(4)) 116 do kk=max(k0-trytoreplace(k0,l0),ppbtab(3)),min(k0+trytoreplace(k0,l0),ppetab(3)) 117 if (parent%array4(i0,j0,kk,ll) /= Agrif_SpecialValue) then 118 tempP%array4(i0,j0,k0,l0) = tempP%array4(i0,j0,k0,l0) + parent%array4(i0,j0,kk,ll) 119 Nbvals = Nbvals + 1 120 endif 121 enddo 122 enddo 123 124 tempP%array4(i0,j0,k0,l0) = tempP%array4(i0,j0,k0,l0) /Nbvals 125 endif 126 enddo 127 enddo 128 endif 129 enddo 130 enddo 131 deallocate(trytoreplace) 132 133 else 134 135 do l0 = pbtab_required(4),petab_required(4) 136 do k0 = pbtab_required(3),petab_required(3) 137 do j0 = pbtab_required(2),petab_required(2) 138 do i0 = pbtab_required(1),petab_required(1) 139 if (tempP%array4(i0,j0,k0,l0) == Agrif_SpecialValue) then 140 ilook = -1 141 call CalculNewValTempP4D((/i0,j0,k0,l0/), & 142 tempP%array4(ppbtab(1),ppbtab(2),ppbtab(3),ppbtab(4)), & 143 parent%array4(ppbtab(1),ppbtab(2),ppbtab(3),ppbtab(4)), & 144 ppbtab,ppetab,noraftab,MaxSearch,Agrif_SpecialValue,ilook) 145 endif 146 enddo 147 enddo 148 enddo 149 enddo 150 151 endif 104 152 case (5) 105 153 do m0 = pbtab(5),petab(5) … … 488 536 !--------------------------------------------------------------------------------------------------- 489 537 subroutine CalculNewValTempP4D ( indic, tempP, parent, ppbtab, ppetab, noraftab, & 490 MaxSearch, Agrif_SpecialValue )538 MaxSearch, Agrif_SpecialValue, ilook ) 491 539 !--------------------------------------------------------------------------------------------------- 492 540 integer, parameter :: nbdim = 4 … … 511 559 ! 512 560 logical :: firsttest 561 integer :: ilook 513 562 ! 514 563 ValMax = 1 … … 528 577 firsttest = .TRUE. 529 578 idecal = indic 579 580 if (ilook /= -1) then 581 i = ilook 582 else 583 i = 1 584 endif 530 585 ! 531 586 do while (i <= ValMax) 532 587 ! 533 if ((i == 1).AND.(firsttest)) i = Valmax588 ! if ((i == 1).AND.(firsttest)) i = Valmax 534 589 535 590 do iii = 1,nbdim … … 537 592 imin(iii) = max(indic(iii) - i,ppbtab(iii)) 538 593 imax(iii) = min(indic(iii) + i,ppetab(iii)) 539 if (firsttest) then540 if (indic(iii) > ppbtab(iii)) then541 idecal(iii) = idecal(iii)-1542 if (tempP(idecal(1),idecal(2),idecal(3),idecal(4)) == Agrif_SpecialValue) then543 imin(iii) = imax(iii)544 endif545 idecal(iii) = idecal(iii)+1546 endif547 endif594 ! if (firsttest) then 595 ! if (indic(iii) > ppbtab(iii)) then 596 ! idecal(iii) = idecal(iii)-1 597 ! if (tempP(idecal(1),idecal(2),idecal(3),idecal(4)) == Agrif_SpecialValue) then 598 ! imin(iii) = imax(iii) 599 ! endif 600 ! idecal(iii) = idecal(iii)+1 601 ! endif 602 ! endif 548 603 endif 549 604 enddo … … 567 622 ! 568 623 if (Nbvals > 0) then 569 if (firsttest) then570 firsttest = .FALSE.571 i=1572 cycle573 endif624 ! if (firsttest) then 625 ! firsttest = .FALSE. 626 ! i=1 627 ! cycle 628 ! endif 574 629 575 630 tempP(indic(1),indic(2),indic(3),indic(4)) = Res/Nbvals 631 ilook = i 576 632 exit 577 633 else 578 if (firsttest) exit634 ! if (firsttest) exit 579 635 i = i + 1 580 636 endif -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modmpp.F90
r5656 r10087 166 166 subroutine Get_External_Data_first ( pttruetab, cetruetab, pttruetabwhole, cetruetabwhole, & 167 167 nbdim, memberoutall, coords, sendtoproc, recvfromproc, & 168 imin, imax, imin_recv, imax_recv )168 imin, imax, imin_recv, imax_recv, bornesmin, bornesmax ) 169 169 !--------------------------------------------------------------------------------------------------- 170 170 include 'mpif.h' … … 179 179 integer, dimension(nbdim,0:Agrif_NbProcs-1), intent(out) :: imin,imax 180 180 integer, dimension(nbdim,0:Agrif_NbProcs-1), intent(out) :: imin_recv,imax_recv 181 integer, dimension(nbdim,0:Agrif_NbProcs-1), intent(in) :: bornesmin, bornesmax 181 182 ! 182 183 integer :: imintmp, imaxtmp, i, j, k, i1 … … 211 212 IF (cetruetab(i,Agrif_Procrank) > cetruetab(i,k)) THEN 212 213 DO j=imin1,imax1 213 IF (( cetruetab(i,k)-j) > (j-pttruetab(i,Agrif_Procrank))) THEN214 IF ((bornesmax(i,k)-j) > (j-bornesmin(i,Agrif_Procrank))) THEN 214 215 imintmp = j+1 215 216 tochange = .TRUE. … … 228 229 IF (pttruetab(i,Agrif_Procrank) < pttruetab(i,k)) THEN 229 230 DO j=imax1,imin1,-1 230 IF ((j- pttruetab(i,k)) > (cetruetab(i,Agrif_Procrank)-j)) THEN231 IF ((j-bornesmin(i,k)) > (bornesmax(i,Agrif_Procrank)-j)) THEN 231 232 imaxtmp = j-1 232 233 tochange = .TRUE. … … 248 249 sendtoproc(k) = .true. 249 250 ! 251 IF ( .not. memberoutall(k) ) THEN 252 sendtoproc(k) = .false. 253 ELSE 250 254 !CDIR SHORTLOOP 251 255 do i = 1,nbdim … … 257 261 endif 258 262 enddo 259 IF ( .not. memberoutall(k) ) THEN260 sendtoproc(k) = .false.261 263 ENDIF 262 264 enddo -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modsauv.F90
r5656 r10087 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_ Variables33 use Agrif_User_Variables 34 34 ! 35 35 implicit none … … 250 250 ! 251 251 type(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive procedure 252 real :: g_eps, eps, oldgrid_eps252 real(kind=8) :: 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 :: g_eps,eps,oldgrid_eps333 real(kind=8) :: 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 , dimension(6) :: snew,sold418 real , dimension(6) :: dsnew,dsold419 real :: eps417 real(kind=8), dimension(6) :: snew,sold 418 real(kind=8), dimension(6) :: dsnew,dsold 419 real(kind=8) :: 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 , dimension(nbdim), intent(in) :: snew, sold534 real , dimension(nbdim), intent(in) :: dsnew,dsold533 real(kind=8), dimension(nbdim), intent(in) :: snew, sold 534 real(kind=8), 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 , dimension(nbdim) :: dim_gmin, dim_gmax540 real , dimension(nbdim) :: dim_newmin, dim_newmax541 real , dimension(nbdim) :: dim_min539 real(kind=8), dimension(nbdim) :: dim_gmin, dim_gmax 540 real(kind=8), dimension(nbdim) :: dim_newmin, dim_newmax 541 real(kind=8), dimension(nbdim) :: dim_min 542 542 integer, dimension(nbdim) :: ind_gmin,ind_newmin, ind_newmax 543 543 ! -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modseq.F90
r5656 r10087 3 3 use Agrif_Init 4 4 use Agrif_Procs 5 use Agrif_Arrays 5 use Agrif_Grids 6 !use Agrif_Arrays 6 7 ! 7 8 implicit none -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modtypes.F90
r5656 r10087 109 109 real(4), dimension(:,:,:,:,:,:), allocatable :: sarray6 110 110 !> @} 111 !> \name Arrays containing the values of the grid variables (real) 112 !> @{ 113 real, dimension(:) , pointer :: parray1 114 real, dimension(:,:) , pointer :: parray2 115 real, dimension(:,:,:) , pointer :: parray3 116 real, dimension(:,:,:,:) , pointer :: parray4 117 real, dimension(:,:,:,:,:) , pointer :: parray5 118 real, dimension(:,:,:,:,:,:), pointer :: parray6 119 !> @} 120 !> \name Arrays containing the values of the grid variables (real*8) 121 !> @{ 122 real(8), dimension(:) , pointer :: pdarray1 123 real(8), dimension(:,:) , pointer :: pdarray2 124 real(8), dimension(:,:,:) , pointer :: pdarray3 125 real(8), dimension(:,:,:,:) , pointer :: pdarray4 126 real(8), dimension(:,:,:,:,:) , pointer :: pdarray5 127 real(8), dimension(:,:,:,:,:,:), pointer :: pdarray6 128 !> @} 129 !> \name Arrays containing the values of the grid variables (real*4) 130 !> @{ 131 real(4), dimension(:) , pointer :: psarray1 132 real(4), dimension(:,:) , pointer :: psarray2 133 real(4), dimension(:,:,:) , pointer :: psarray3 134 real(4), dimension(:,:,:,:) , pointer :: psarray4 135 real(4), dimension(:,:,:,:,:) , pointer :: psarray5 136 real(4), dimension(:,:,:,:,:,:), pointer :: psarray6 137 !> @} 111 138 !> \name Arrays used to restore the values 112 139 !> @{ … … 132 159 integer, dimension(6) :: ub 133 160 161 integer, dimension(6,2) :: lubglob 162 134 163 logical,dimension(6,2) :: memberin 135 164 integer,dimension(6,2,2,6,2) :: childarray … … 153 182 !> \name Arrays containing the values of the grid variables (character) 154 183 !> @{ 155 character( 2400) :: carray0156 character( 200), dimension(:) , allocatable :: carray1157 character( 200), dimension(:,:), allocatable :: carray2184 character(4000) :: carray0 185 character(400), dimension(:) , allocatable :: carray1 186 character(400), dimension(:,:), allocatable :: carray2 158 187 !> @} 159 188 !--------------------------------------------------------------------------------------------------- … … 218 247 !> \name Arrays containing the values of the grid variables (logical) 219 248 !> @{ 220 logical :: larray0 249 logical :: larray0 = .FALSE. 221 250 logical, dimension(:) , allocatable :: larray1 222 251 logical, dimension(:,:) , allocatable :: larray2 … … 242 271 !> \name Arrays containing the values of the grid variables (integer) 243 272 !> @{ 244 integer :: iarray0 273 integer :: iarray0 = 0 245 274 integer, dimension(:) , allocatable :: iarray1 246 275 integer, dimension(:,:) , allocatable :: iarray2 … … 259 288 integer,dimension(6) :: pttab, petab, pttab_Child, pttab_Parent = -99 260 289 integer,dimension(6) :: indmin, indmax 290 integer,dimension(6) :: indmin_required_p, indmax_required_p 261 291 integer,dimension(6) :: pttruetab,cetruetab 262 292 logical :: member, memberin … … 324 354 real :: Agrif_Efficiency = 0.7 325 355 integer :: MaxSearch = 5 326 real , dimension(3) :: Agrif_mind356 real(kind=8), dimension(3) :: Agrif_mind 327 357 !> @} 328 358 !> \name parameters for the interpolation of the child grids … … 388 418 integer function Agrif_Ceiling ( x ) 389 419 !--------------------------------------------------------------------------------------------------- 390 real ,intent(in) :: x420 real(kind=8),intent(in) :: x 391 421 ! 392 422 integer :: i … … 408 438 integer function Agrif_Int(x) 409 439 !--------------------------------------------------------------------------------------------------- 410 real ,intent(in) :: x440 real(kind=8),intent(in) :: x 411 441 ! 412 442 integer :: i -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modupdate.F90
r5656 r10087 27 27 module Agrif_Update 28 28 ! 29 ! use Agrif_UpdateBasic 30 ! use Agrif_Arrays 31 ! use Agrif_CurgridFunctions 32 ! use Agrif_Mask 33 #if defined AGRIF_MPI 34 ! use Agrif_Mpp 35 #endif 36 ! 29 37 use Agrif_UpdateBasic 30 38 use Agrif_Arrays 31 use Agrif_CurgridFunctions 39 use Agrif_User_Functions 40 use Agrif_Init 32 41 use Agrif_Mask 42 33 43 #if defined AGRIF_MPI 34 44 use Agrif_Mpp … … 58 68 integer, dimension(6) :: ub_child 59 69 integer, dimension(6) :: lb_parent 60 real , dimension(6) :: s_child ! Child grid position (s_root = 0)61 real , dimension(6) :: s_parent ! Parent grid position (s_root = 0)62 real , dimension(6) :: ds_child ! Child grid dx (ds_root = 1)63 real , dimension(6) :: ds_parent ! Parent grid dx (ds_root = 1)70 real(kind=8) , dimension(6) :: s_child ! Child grid position (s_root = 0) 71 real(kind=8) , dimension(6) :: s_parent ! Parent grid position (s_root = 0) 72 real(kind=8) , dimension(6) :: ds_child ! Child grid dx (ds_root = 1) 73 real(kind=8) , dimension(6) :: ds_parent ! Parent grid dx (ds_root = 1) 64 74 logical, dimension(6) :: do_update ! Indicates if we perform update for each dimension 65 75 integer, dimension(6) :: posvar ! Position of the variable on the cell (1 or 2) … … 160 170 integer, dimension(nbdim), intent(in) :: posvar !< Position of the variable on the cell (1 or 2) 161 171 logical, dimension(nbdim), intent(in) :: do_update !< Indicates if we update for each dimension 162 real , dimension(nbdim), intent(in) :: s_child !< Positions of the child grid163 real , dimension(nbdim), intent(in) :: s_parent !< Positions of the parent grid164 real , dimension(nbdim), intent(in) :: ds_child !< Space steps of the child grid165 real , dimension(nbdim), intent(in) :: ds_parent !< Space steps of the parent grid172 real(kind=8), dimension(nbdim), intent(in) :: s_child !< Positions of the child grid 173 real(kind=8), dimension(nbdim), intent(in) :: s_parent !< Positions of the parent grid 174 real(kind=8), dimension(nbdim), intent(in) :: ds_child !< Space steps of the child grid 175 real(kind=8), dimension(nbdim), intent(in) :: ds_parent !< Space steps of the parent grid 166 176 procedure() :: procname !< Data recovery procedure 167 177 ! … … 230 240 ! lubglob(:,2) : global lbound for each dimension 231 241 ! 232 call Agrif_get_var_global_bounds(child, lubglob, nbdim) 242 ! call Agrif_get_var_global_bounds(child, lubglob, nbdim) 243 lubglob = child % lubglob(1:nbdim,:) 233 244 ! 234 245 indtruetab(1:nbdim,1,1) = max(indtab(1:nbdim,1,1), lubglob(1:nbdim,1)) … … 274 285 integer, dimension(nbdim), intent(in) :: posvar !< Position of the variable on the cell (1 or 2) 275 286 logical, dimension(nbdim), intent(in) :: do_update !< Indicates if we update for each dimension 276 real , dimension(nbdim), intent(in) :: s_child !< Positions of the child grid277 real , dimension(nbdim), intent(in) :: s_parent !< Positions of the parent grid278 real , dimension(nbdim), intent(in) :: ds_child !< Space steps of the child grid279 real , dimension(nbdim), intent(in) :: ds_parent !< Space steps of the parent grid287 real(kind=8), dimension(nbdim), intent(in) :: s_child !< Positions of the child grid 288 real(kind=8), dimension(nbdim), intent(in) :: s_parent !< Positions of the parent grid 289 real(kind=8), dimension(nbdim), intent(in) :: ds_child !< Space steps of the child grid 290 real(kind=8), dimension(nbdim), intent(in) :: ds_parent !< Space steps of the parent grid 280 291 procedure() :: procname !< Data recovery procedure 281 292 ! … … 390 401 #endif 391 402 ! 392 integer, dimension(6), intent(in) :: type_update !< Type of update (copy or average)393 403 type(Agrif_Variable), pointer :: parent !< Variable of the parent grid 394 404 type(Agrif_Variable), pointer :: child !< Variable of the child grid 395 405 integer, intent(in) :: nbdim 406 integer, dimension(nbdim), intent(in) :: type_update !< Type of update (copy or average) 396 407 integer, dimension(nbdim), intent(in) :: pttab !< Index of the first point inside the domain 397 408 integer, dimension(nbdim), intent(in) :: petab !< Index of the first point inside the domain … … 400 411 integer, dimension(nbdim), intent(in) :: lb_parent !< Index of the first point inside the domain for the parent 401 412 !! grid variable 402 real , dimension(nbdim), intent(in) :: s_child !< Positions of the child grid403 real , dimension(nbdim), intent(in) :: s_parent !< Positions of the parent grid404 real , dimension(nbdim), intent(in) :: ds_child !< Space steps of the child grid405 real , dimension(nbdim), intent(in) :: ds_parent !< Space steps of the parent grid413 real(kind=8), dimension(nbdim), intent(in) :: s_child !< Positions of the child grid 414 real(kind=8), dimension(nbdim), intent(in) :: s_parent !< Positions of the parent grid 415 real(kind=8), dimension(nbdim), intent(in) :: ds_child !< Space steps of the child grid 416 real(kind=8), dimension(nbdim), intent(in) :: ds_parent !< Space steps of the parent grid 406 417 procedure() :: procname !< Data recovery procedure 407 418 integer, optional, intent(in) :: nb, ndir … … 415 426 integer, dimension(nbdim) :: indmin, indmax 416 427 integer, dimension(nbdim) :: indminglob, indmaxglob 417 real , dimension(nbdim) :: s_Child_temp, s_Parent_temp428 real(kind=8) , dimension(nbdim) :: s_Child_temp, s_Parent_temp 418 429 integer, dimension(nbdim) :: lowerbound,upperbound 419 430 integer, dimension(nbdim) :: pttruetabwhole, cetruetabwhole … … 450 461 real :: coeff_multi 451 462 integer :: nb_dimensions 463 452 464 ! 453 465 ! Get local lower and upper bound of the child variable … … 506 518 ! 507 519 call Agrif_array_allocate(tempC,pttruetab,cetruetab,nbdim) 520 #if defined AGRIF_MPI 508 521 call Agrif_var_set_array_tozero(tempC,nbdim) 522 #endif 509 523 510 524 SELECT CASE (nbdim) … … 582 596 nbdim, memberinall, coords, & 583 597 sendtoproc1,recvfromproc1, & 584 tab4t(:,:,5),tab4t(:,:,6),tab4t(:,:,7),tab4t(:,:,8)) 598 tab4t(:,:,5),tab4t(:,:,6),tab4t(:,:,7),tab4t(:,:,8), & 599 tab4t(:,:,1),tab4t(:,:,2)) 585 600 endif 586 601 … … 600 615 ! 601 616 call Agrif_array_allocate(tempP,indmin,indmax,nbdim) 602 ! 617 618 IF (Agrif_UseSpecialValueInUpdate) THEN 619 allocate(tempC_indic) 620 allocate(tempP_indic) 621 call Agrif_array_allocate(tempC_indic,pttruetabwhole,cetruetabwhole,nbdim) 622 call Agrif_array_allocate(tempP_indic,indmin,indmax,nbdim) 623 call agrif_set_array_cond(tempCextend,tempC_indic,agrif_SpecialValueFineGrid,nbdim) 624 ELSE 625 tempC_indic=>tempCextend ! Just to associate tempC_indic to something ... 626 ENDIF 627 ! 628 629 603 630 if ( nbdim == 1 ) then 604 631 tempP % array1 = 0. … … 606 633 tempP%array1, & 607 634 tempCextend%array1, & 635 tempC_indic%array1, & 608 636 indmin(1), indmax(1), & 609 637 pttruetabwhole(1), cetruetabwhole(1), & … … 612 640 613 641 IF (Agrif_UseSpecialValueInUpdate) THEN 614 allocate(tempC_indic)615 allocate(tempP_indic)616 call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array1),ubound(tempCextend%array1),nbdim)617 call Agrif_array_allocate(tempP_indic,lbound(tempP%array1),ubound(tempP%array1),nbdim)618 642 619 643 compute_average = .FALSE. … … 629 653 tempP_average%array1, & 630 654 tempCextend%array1, & 655 tempC_indic%array1, & 631 656 indmin(1), indmax(1), & 632 657 pttruetabwhole(1), cetruetabwhole(1), & … … 639 664 ENDIF 640 665 641 WHERE (tempCextend%array1 == Agrif_SpecialValueFineGrid)642 tempC_indic%array1 = 0.643 ELSEWHERE644 tempC_indic%array1 = 1.645 END WHERE646 647 666 Agrif_UseSpecialValueInUpdate = .FALSE. 648 667 Agrif_Update_Weights = .TRUE. … … 650 669 call Agrif_Update_1D_Recursive( type_update_temp(1), & 651 670 tempP_indic%array1, & 671 tempC_indic%array1, & 652 672 tempC_indic%array1, & 653 673 indmin(1), indmax(1), & … … 691 711 tempP%array2, & 692 712 tempCextend%array2, & 713 tempC_indic%array2, & 693 714 indmin(1:2), indmax(1:2), & 694 715 pttruetabwhole(1:2), cetruetabwhole(1:2), & … … 697 718 698 719 IF (Agrif_UseSpecialValueInUpdate) THEN 699 allocate(tempC_indic)700 allocate(tempP_indic)701 call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array2),ubound(tempCextend%array2),nbdim)702 call Agrif_array_allocate(tempP_indic,lbound(tempP%array2),ubound(tempP%array2),nbdim)703 720 704 721 compute_average = .FALSE. … … 714 731 tempP_average%array2, & 715 732 tempCextend%array2, & 733 tempC_indic%array2, & 716 734 indmin(1:2), indmax(1:2), & 717 735 pttruetabwhole(1:2), cetruetabwhole(1:2), & … … 724 742 ENDIF 725 743 726 WHERE (tempCextend%array2 == Agrif_SpecialValueFineGrid)727 tempC_indic%array2 = 0.728 ELSEWHERE729 tempC_indic%array2 = 1.730 END WHERE731 732 744 Agrif_UseSpecialValueInUpdate = .FALSE. 733 745 Agrif_Update_Weights = .TRUE. … … 735 747 call Agrif_Update_2D_Recursive( type_update_temp(1:2), & 736 748 tempP_indic%array2, & 749 tempC_indic%array2, & 737 750 tempC_indic%array2, & 738 751 indmin(1:2), indmax(1:2), & … … 773 786 endif 774 787 if ( nbdim == 3 ) then 788 775 789 call Agrif_Update_3D_Recursive( type_update(1:3), & 776 790 tempP%array3, & 777 791 tempCextend%array3, & 792 tempC_indic%array3, & 778 793 indmin(1:3), indmax(1:3), & 779 794 pttruetabwhole(1:3), cetruetabwhole(1:3), & 780 795 s_Child_temp(1:3), s_Parent_temp(1:3), & 781 796 ds_child(1:3), ds_parent(1:3) ) 782 797 798 783 799 IF (Agrif_UseSpecialValueInUpdate) THEN 784 allocate(tempC_indic)785 allocate(tempP_indic)786 call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array3),ubound(tempCextend%array3),nbdim)787 call Agrif_array_allocate(tempP_indic,lbound(tempP%array3),ubound(tempP%array3),nbdim)788 800 789 801 compute_average = .FALSE. … … 796 808 type_update_temp(1:nbdim) = Agrif_Update_Average 797 809 END WHERE 810 798 811 call Agrif_Update_3D_Recursive( type_update_temp(1:3), & 799 812 tempP_average%array3, & 800 813 tempCextend%array3, & 814 tempC_indic%array3, & 801 815 indmin(1:3), indmax(1:3), & 802 816 pttruetabwhole(1:3), cetruetabwhole(1:3), & … … 808 822 enddo 809 823 ENDIF 810 811 WHERE (tempCextend%array3 == Agrif_SpecialValueFineGrid) 812 tempC_indic%array3 = 0. 813 ELSEWHERE 814 tempC_indic%array3 = 1. 815 END WHERE 816 824 817 825 Agrif_UseSpecialValueInUpdate = .FALSE. 818 826 Agrif_Update_Weights = .TRUE. 819 827 828 820 829 call Agrif_Update_3D_Recursive( type_update_temp(1:3), & 821 830 tempP_indic%array3, & 822 831 tempC_indic%array3, & 832 tempCextend%array3, & 823 833 indmin(1:3), indmax(1:3), & 824 834 pttruetabwhole(1:3), cetruetabwhole(1:3), & … … 826 836 ds_child(1:3), ds_parent(1:3) ) 827 837 838 828 839 Agrif_UseSpecialValueInUpdate = .TRUE. 829 840 Agrif_Update_Weights = .FALSE. 830 841 842 831 843 IF (compute_average) THEN 844 832 845 WHERE (tempP_indic%array3 == 0.) 833 846 tempP%array3 = Agrif_SpecialValueFineGrid … … 837 850 tempP%array3 = tempP_average%array3 /tempP_indic%array3 838 851 END WHERE 839 852 840 853 ELSE 841 854 WHERE (tempP_indic%array3 == 0.) … … 845 858 END WHERE 846 859 ENDIF 847 860 848 861 deallocate(tempP_indic%array3) 849 862 deallocate(tempC_indic%array3) … … 855 868 ENDIF 856 869 ENDIF 857 870 871 858 872 endif 859 873 if ( nbdim == 4 ) then 874 860 875 call Agrif_Update_4D_Recursive( type_update(1:4), & 861 876 tempP%array4, & 862 877 tempCextend%array4, & 878 tempC_indic%array4, & 863 879 indmin(1:4), indmax(1:4), & 864 880 pttruetabwhole(1:4), cetruetabwhole(1:4), & 865 881 s_Child_temp(1:4), s_Parent_temp(1:4), & 866 882 ds_child(1:4), ds_parent(1:4) ) 867 883 868 884 IF (Agrif_UseSpecialValueInUpdate) THEN 869 870 allocate(tempC_indic)871 allocate(tempP_indic)872 call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array4),ubound(tempCextend%array4),nbdim)873 call Agrif_array_allocate(tempP_indic,lbound(tempP%array4),ubound(tempP%array4),nbdim)874 885 875 886 compute_average = .FALSE. … … 885 896 tempP_average%array4, & 886 897 tempCextend%array4, & 898 tempC_indic%array4, & 887 899 indmin(1:4), indmax(1:4), & 888 900 pttruetabwhole(1:4), cetruetabwhole(1:4), & … … 895 907 ENDIF 896 908 897 WHERE (tempCextend%array4 == Agrif_SpecialValueFineGrid)898 tempC_indic%array4 = 0.899 ELSEWHERE900 tempC_indic%array4 = 1.901 END WHERE902 903 909 Agrif_UseSpecialValueInUpdate = .FALSE. 904 910 Agrif_Update_Weights = .TRUE. … … 906 912 call Agrif_Update_4D_Recursive( type_update_temp(1:4), & 907 913 tempP_indic%array4, & 914 tempC_indic%array4, & 908 915 tempC_indic%array4, & 909 916 indmin(1:4), indmax(1:4), & … … 940 947 ENDIF 941 948 ENDIF 942 949 943 950 endif 944 951 if ( nbdim == 5 ) then … … 946 953 tempP%array5, & 947 954 tempCextend%array5, & 955 tempC_indic%array5, & 948 956 indmin(1:5), indmax(1:5), & 949 957 pttruetabwhole(1:5), cetruetabwhole(1:5), & … … 952 960 953 961 IF (Agrif_UseSpecialValueInUpdate) THEN 954 allocate(tempC_indic)955 allocate(tempP_indic)956 call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array5),ubound(tempCextend%array5),nbdim)957 call Agrif_array_allocate(tempP_indic,lbound(tempP%array5),ubound(tempP%array5),nbdim)958 962 959 963 compute_average = .FALSE. … … 969 973 tempP_average%array5, & 970 974 tempCextend%array5, & 975 tempC_indic%array5, & 971 976 indmin(1:5), indmax(1:5), & 972 977 pttruetabwhole(1:5), cetruetabwhole(1:5), & … … 979 984 ENDIF 980 985 981 WHERE (tempCextend%array5 == Agrif_SpecialValueFineGrid)982 tempC_indic%array5 = 0.983 ELSEWHERE984 tempC_indic%array5 = 1.985 END WHERE986 987 986 Agrif_UseSpecialValueInUpdate = .FALSE. 988 987 Agrif_Update_Weights = .TRUE. … … 990 989 call Agrif_Update_5D_Recursive( type_update_temp(1:5), & 991 990 tempP_indic%array5, & 991 tempC_indic%array5, & 992 992 tempC_indic%array5, & 993 993 indmin(1:5), indmax(1:5), & … … 1031 1031 tempP%array6, & 1032 1032 tempCextend%array6, & 1033 tempC_indic%array6, & 1033 1034 indmin(1:6), indmax(1:6), & 1034 1035 pttruetabwhole(1:6), cetruetabwhole(1:6), & 1035 1036 s_Child_temp(1:6), s_Parent_temp(1:6), & 1036 1037 ds_child(1:6), ds_parent(1:6) ) 1038 1037 1039 IF (Agrif_UseSpecialValueInUpdate) THEN 1038 allocate(tempC_indic)1039 allocate(tempP_indic)1040 call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array6),ubound(tempCextend%array6),nbdim)1041 call Agrif_array_allocate(tempP_indic,lbound(tempP%array6),ubound(tempP%array6),nbdim)1042 1040 1043 1041 compute_average = .FALSE. … … 1054 1052 tempP_average%array6, & 1055 1053 tempCextend%array6, & 1054 tempC_indic%array6, & 1056 1055 indmin(1:6), indmax(1:6), & 1057 1056 pttruetabwhole(1:6), cetruetabwhole(1:6), & … … 1064 1063 ENDIF 1065 1064 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 1066 1081 IF (compute_average) THEN 1067 1082 WHERE (tempP_indic%array6 == 0.) … … 1080 1095 END WHERE 1081 1096 ENDIF 1082 1083 Agrif_UseSpecialValueInUpdate = .FALSE.1084 Agrif_Update_Weights = .TRUE.1085 1086 call Agrif_Update_6D_Recursive( type_update_temp(1:6), &1087 tempP_indic%array6, &1088 tempC_indic%array6, &1089 indmin(1:6), indmax(1:6), &1090 pttruetabwhole(1:6), cetruetabwhole(1:6), &1091 s_Child_temp(1:6), s_Parent_temp(1:6), &1092 ds_child(1:6), ds_parent(1:6) )1093 1094 Agrif_UseSpecialValueInUpdate = .TRUE.1095 Agrif_Update_Weights = .FALSE.1096 1097 WHERE (tempP_indic%array6 == 0.)1098 tempP%array6 = Agrif_SpecialValueFineGrid1099 ELSEWHERE1100 tempP%array6 = tempP%array6 /tempP_indic%array61101 END WHERE1102 1097 1103 1098 deallocate(tempP_indic%array6) … … 1154 1149 nbdim, memberinall2, coords, & 1155 1150 sendtoproc2, recvfromproc2, & 1156 tab5t(:,:,5),tab5t(:,:,6),tab5t(:,:,7),tab5t(:,:,8)) 1151 tab5t(:,:,5),tab5t(:,:,6),tab5t(:,:,7),tab5t(:,:,8), & 1152 tab5t(:,:,1),tab5t(:,:,2)) 1157 1153 1158 1154 call Agrif_Addto_list_update(child%list_update,pttab,petab,lb_child,lb_parent, & … … 1323 1319 integer, intent(in) :: nbdim 1324 1320 integer, dimension(nbdim), intent(out) :: indmin, indmax 1325 real , dimension(nbdim), intent(out) :: s_Parent_temp, s_Child_temp1326 real , dimension(nbdim), intent(in) :: s_child, ds_child1327 real , dimension(nbdim), intent(in) :: s_parent, ds_parent1321 real(kind=8), dimension(nbdim), intent(out) :: s_Parent_temp, s_Child_temp 1322 real(kind=8), dimension(nbdim), intent(in) :: s_child, ds_child 1323 real(kind=8), dimension(nbdim), intent(in) :: s_parent, ds_parent 1328 1324 integer, dimension(nbdim), intent(in) :: pttruetab, cetruetab 1329 1325 integer, dimension(nbdim), intent(in) :: lb_child, lb_parent … … 1335 1331 #endif 1336 1332 ! 1337 real ,dimension(nbdim) :: dim_newmin,dim_newmax1333 real(kind=8),dimension(nbdim) :: dim_newmin,dim_newmax 1338 1334 integer :: i 1339 1335 #if defined AGRIF_MPI 1340 real :: positionmin, positionmax1336 real(kind=8) :: positionmin, positionmax 1341 1337 integer :: imin, imax 1342 1338 integer :: coeffraf … … 1422 1418 !> Updates a 1D grid variable on the parent grid 1423 1419 !--------------------------------------------------------------------------------------------------- 1424 subroutine Agrif_Update_1D_Recursive ( type_update, &1425 tempP, tempC, &1426 indmin, indmax, &1427 lb_child, ub_child, &1428 s_child, s_parent, &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, & 1429 1425 ds_child, ds_parent ) 1430 1426 !--------------------------------------------------------------------------------------------------- … … 1432 1428 integer, intent(in) :: indmin, indmax 1433 1429 integer, intent(in) :: lb_child, ub_child 1434 real , intent(in) :: s_child, s_parent1435 real , intent(in) :: ds_child, ds_parent1430 real(kind=8), intent(in) :: s_child, s_parent 1431 real(kind=8), intent(in) :: ds_child, ds_parent 1436 1432 real, dimension(indmin:indmax), intent(out) :: tempP 1437 real, dimension(lb_child:ub_child), intent(in) :: tempC 1433 real, dimension(lb_child:ub_child), intent(in) :: tempC, tempC_indic 1438 1434 !--------------------------------------------------------------------------------------------------- 1439 1435 call Agrif_UpdateBase(type_update, & … … 1454 1450 !! Calls #Agrif_Update_1D_Recursive and #Agrif_UpdateBase 1455 1451 !--------------------------------------------------------------------------------------------------- 1456 subroutine Agrif_Update_2D_Recursive ( type_update, &1457 tempP, tempC, &1458 indmin, indmax, &1459 lb_child, ub_child, &1460 s_child, s_parent,&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, & 1461 1457 ds_child, ds_parent ) 1462 1458 !--------------------------------------------------------------------------------------------------- … … 1464 1460 integer, dimension(2), intent(in) :: indmin, indmax 1465 1461 integer, dimension(2), intent(in) :: lb_child, ub_child 1466 real , dimension(2), intent(in) :: s_child, s_parent1467 real , dimension(2), intent(in) :: ds_child, ds_parent1462 real(kind=8), dimension(2), intent(in) :: s_child, s_parent 1463 real(kind=8), dimension(2), intent(in) :: ds_child, ds_parent 1468 1464 real, dimension( & 1469 1465 indmin(1):indmax(1), & 1470 1466 indmin(2):indmax(2)), intent(out) :: tempP 1471 real, dimension(:,:), intent(in) :: tempC 1467 real, dimension(:,:), intent(in) :: tempC, tempC_indic 1472 1468 !--------------------------------------------------------------------------------------------------- 1473 1469 real, dimension(indmin(1):indmax(1), lb_child(2):ub_child(2)) :: tabtemp … … 1475 1471 real, dimension(lb_child(2):ub_child(2), indmin(1):indmax(1)) :: tabtemp_trsp 1476 1472 integer :: i, j 1477 integer :: coeffraf 1478 ! 1479 tabtemp = 0. 1473 integer :: coeffraf, coeffraf_2 1474 integer :: jmin,jmax 1475 integer locind_child_left, locind_child_left_2,kuinf 1476 logical :: to_transpose 1477 real :: invcoeffraf 1478 integer :: diffmod, jj,i1,j1 1479 1480 1481 to_transpose = .TRUE. 1482 ! 1483 1480 1484 coeffraf = nint ( ds_parent(1) / ds_child(1) ) 1481 1485 ! … … 1490 1494 endif 1491 1495 !---CDIR NEXPAND 1496 tabtemp = 0. 1492 1497 call Average1dAfterCompute( tabtemp, tempC, size(tabtemp), size(tempC), & 1493 1498 s_parent(1),s_child(1),ds_parent(1),ds_child(1),1) … … 1503 1508 endif 1504 1509 !---CDIR NEXPAND 1510 1505 1511 call Agrif_basicupdate_copy1d_after(tabtemp,tempC,size(tabtemp),size(tempC),1) 1506 1512 ! 1513 ELSE IF ((coeffraf == 1).AND.(type_update(2) == Agrif_Update_Average)) THEN 1514 locind_child_left = 1+agrif_int((s_parent(1)-s_child(1))/ds_child(1)) 1515 coeffraf_2 = nint ( ds_parent(2) / ds_child(2) ) 1516 invcoeffraf = 1./coeffraf_2 1517 tempP = 0. 1518 diffmod = 0 1519 if (mod(coeffraf_2,2) == 0) diffmod = 1 1520 locind_child_left_2 = 1+agrif_int((s_parent(2)-s_child(2))/ds_child(2)) 1521 1522 if (Agrif_UseSpecialValueInUpdate) then 1523 j1 = -coeffraf_2/2+locind_child_left_2+diffmod 1524 do j=indmin(2),indmax(2) 1525 do jj=j1,j1+coeffraf_2-1 1526 i1 = locind_child_left 1527 do i=indmin(1),indmax(1) 1528 tempP(i,j) = tempP(i,j) + tempC(i1,jj)*tempC_indic(i1,jj) 1529 i1 = i1 + 1 1530 enddo 1531 enddo 1532 j1 = j1 + coeffraf_2 1533 enddo 1534 else 1535 j1 = -coeffraf_2/2+locind_child_left_2+diffmod 1536 do j=indmin(2),indmax(2) 1537 do jj=j1,j1+coeffraf_2-1 1538 do i=indmin(1),indmax(1) 1539 tempP(i,j) = tempP(i,j) + tempC(locind_child_left+i-indmin(1),jj) 1540 enddo 1541 enddo 1542 j1 = j1 + coeffraf_2 1543 enddo 1544 if (.not.Agrif_Update_Weights) tempP = tempP * invcoeffraf 1545 endif 1546 return 1547 ! 1548 ELSE IF ((coeffraf == 1).AND.(type_update(2) == Agrif_Update_Copy)) THEN 1549 1550 locind_child_left = 1 + agrif_int((s_parent(1)-s_child(1))/ds_child(1)) 1551 ! 1552 locind_child_left_2 = 1+nint((s_parent(2)-s_child(2))/ds_child(2)) 1553 coeffraf_2 = nint ( ds_parent(2) / ds_child(2) ) 1554 1555 do j=indmin(2),indmax(2) 1556 do i=indmin(1),indmax(1) 1557 tempP(i,j) = tempC(locind_child_left+i-indmin(1),locind_child_left_2) 1558 enddo 1559 locind_child_left_2 = locind_child_left_2 + coeffraf_2 1560 enddo 1561 1562 return 1563 1564 ELSE IF (coeffraf == 1) THEN 1565 locind_child_left = 1 + agrif_int((s_parent(1)-s_child(1))/ds_child(1)) 1566 ! 1567 do j = lb_child(2),ub_child(2) 1568 ! tabtemp(indmin(1):indmax(1),j) = tempC(locind_child_left:locind_child_left+indmax(1)-indmin(1),j-lb_child(2)+1) 1569 tabtemp_trsp(j,indmin(1):indmax(1)) = tempC(locind_child_left:locind_child_left+indmax(1)-indmin(1),j-lb_child(2)+1) 1570 enddo 1571 to_transpose = .FALSE. 1507 1572 ELSE 1508 1573 do j = lb_child(2),ub_child(2) … … 1512 1577 tabtemp(:,j), & 1513 1578 tempC(:,j-lb_child(2)+1), & 1579 tempC_indic(:,j-lb_child(2)+1), & 1514 1580 indmin(1), indmax(1), & 1515 1581 lb_child(1),ub_child(1), & … … 1519 1585 ENDIF 1520 1586 ! 1521 tabtemp_trsp = TRANSPOSE(tabtemp) 1587 1588 if (to_transpose) tabtemp_trsp = TRANSPOSE(tabtemp) 1589 1522 1590 coeffraf = nint(ds_parent(2)/ds_child(2)) 1523 1591 ! … … 1564 1632 ENDIF 1565 1633 ! 1634 1635 1566 1636 tempP = TRANSPOSE(tempP_trsp) 1567 1637 !--------------------------------------------------------------------------------------------------- 1568 1638 end subroutine Agrif_Update_2D_Recursive 1569 !===================================================================================================1570 !1571 subroutine Agrif_Update_2D_Recursive_ok ( type_update, &1572 tempP, tempC, &1573 indmin, indmax, &1574 lb_child, ub_child, &1575 s_child, s_parent, ds_child, ds_parent )1576 !---------------------------------------------------------------------------------------------------1577 INTEGER, DIMENSION(2), intent(in) :: type_update !< Type of update (copy or average)1578 INTEGER, DIMENSION(2), intent(in) :: indmin, indmax1579 INTEGER, DIMENSION(2), intent(in) :: lb_child, ub_child1580 REAL, DIMENSION(2), intent(in) :: s_child, s_parent1581 REAL, DIMENSION(2), intent(in) :: ds_child, ds_parent1582 REAL, DIMENSION( &1583 indmin(1):indmax(1), &1584 indmin(2):indmax(2)), intent(out) :: tempP1585 REAL, DIMENSION( &1586 lb_child(1):ub_child(1), &1587 lb_child(2):ub_child(2)), intent(in) :: tempC1588 !1589 REAL, DIMENSION(indmin(1):indmax(1), lb_child(2):ub_child(2)) :: tabtemp1590 INTEGER :: i1591 !1592 do i = lb_child(2),ub_child(2)1593 call Agrif_Update_1D_Recursive(type_update(1), &1594 tabtemp(:, i), &1595 tempC(:,i), &1596 indmin(1),indmax(1), &1597 lb_child(1),ub_child(1), &1598 s_child(1), s_parent(1), &1599 ds_child(1),ds_parent(1))1600 enddo1601 !1602 tempP = 0.1603 !1604 do i = indmin(1),indmax(1)1605 call Agrif_UpdateBase(type_update(2), &1606 tempP(i,:), &1607 tabtemp(i,:), &1608 indmin(2),indmax(2), &1609 lb_child(2),ub_child(2), &1610 s_parent(2),s_child(2), &1611 ds_parent(2),ds_child(2))1612 enddo1613 !---------------------------------------------------------------------------------------------------1614 end subroutine Agrif_Update_2D_Recursive_ok1615 1639 !=================================================================================================== 1616 1640 … … 1622 1646 !! Calls #Agrif_Update_2D_Recursive and #Agrif_UpdateBase. 1623 1647 !--------------------------------------------------------------------------------------------------- 1624 subroutine Agrif_Update_3D_Recursive ( type_update, &1625 tempP, tempC, &1626 indmin, indmax, &1627 lb_child, ub_child, &1628 s_child, s_parent,&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, & 1629 1653 ds_child, ds_parent ) 1630 1654 !--------------------------------------------------------------------------------------------------- … … 1632 1656 integer, dimension(3), intent(in) :: indmin, indmax 1633 1657 integer, dimension(3), intent(in) :: lb_child, ub_child 1634 real , dimension(3), intent(in) :: s_child, s_parent1635 real , dimension(3), intent(in) :: ds_child, ds_parent1658 real(kind=8), dimension(3), intent(in) :: s_child, s_parent 1659 real(kind=8), dimension(3), intent(in) :: ds_child, ds_parent 1636 1660 real, dimension( & 1637 1661 indmin(1):indmax(1), & … … 1641 1665 lb_child(1):ub_child(1), & 1642 1666 lb_child(2):ub_child(2), & 1643 lb_child(3):ub_child(3)), intent(in) :: tempC 1667 lb_child(3):ub_child(3)), intent(in) :: tempC, tempC_indic 1644 1668 !--------------------------------------------------------------------------------------------------- 1645 1669 real, dimension( & … … 1650 1674 integer :: coeffraf,locind_child_left 1651 1675 integer :: kuinf 1676 REAL :: invcoeffraf 1677 INTEGER :: diffmod, kk 1652 1678 ! 1653 1679 coeffraf = nint ( ds_parent(1) / ds_child(1) ) … … 1687 1713 endif 1688 1714 ! 1715 ! do k = lb_child(3),ub_child(3) 1716 ! call Agrif_Update_2D_Recursive( type_update(1:2),tabtemp(:,:,k),tempC(:,:,k), & 1717 ! indmin(1:2),indmax(1:2), & 1718 ! lb_child(1:2),ub_child(1:2), & 1719 ! s_child(1:2),s_parent(1:2), & 1720 ! ds_child(1:2),ds_parent(1:2) ) 1721 ! enddo 1722 1723 1689 1724 do k = lb_child(3),ub_child(3) 1690 call Agrif_Update_2D_Recursive( type_update (1:2),tabtemp(:,:,k),tempC(:,:,k), &1691 indmin (1:2),indmax(1:2), &1692 lb_child (1:2),ub_child(1:2), &1693 s_child (1:2),s_parent(1:2), &1694 ds_child (1:2),ds_parent(1:2))1725 call Agrif_Update_2D_Recursive( type_update,tabtemp(:,:,k),tempC(:,:,k),tempC_indic(:,:,k), & 1726 indmin,indmax, & 1727 lb_child,ub_child, & 1728 s_child,s_parent, & 1729 ds_child,ds_parent) 1695 1730 enddo 1731 1696 1732 ! 1697 1733 precomputedone(1) = .FALSE. … … 1711 1747 enddo 1712 1748 enddo 1749 else if (type_update(3) == Agrif_Update_Copy) then 1750 locind_child_left = lb_child(3) + nint((s_parent(3)-s_child(3))/ds_child(3)) 1751 1752 do k=indmin(3),indmax(3) 1753 do j = indmin(2),indmax(2) 1754 do i = indmin(1),indmax(1) 1755 tempP(i,j,k) = tabtemp(i,j,locind_child_left) 1756 enddo 1757 enddo 1758 locind_child_left = locind_child_left + coeffraf 1759 enddo 1760 else if (type_update(3) == Agrif_Update_Average) then 1761 invcoeffraf = 1./coeffraf 1762 tempP = 0. 1763 diffmod = 0 1764 if (mod(coeffraf,2) == 0) diffmod=1 1765 locind_child_left = lb_child(3) + agrif_int((s_parent(3)-s_child(3))/ds_child(3)) 1766 if (Agrif_UseSpecialValueInUpdate) then 1767 do k=indmin(3),indmax(3) 1768 do kk=-coeffraf/2+locind_child_left+diffmod, & 1769 coeffraf/2+locind_child_left 1770 do j=indmin(2),indmax(2) 1771 do i=indmin(1),indmax(1) 1772 if (tabtemp(i,j,kk) /= Agrif_SpecialValueFineGrid) then 1773 tempP(i,j,k) = tempP(i,j,k) + tabtemp(i,j,kk) 1774 endif 1775 enddo 1776 enddo 1777 enddo 1778 locind_child_left = locind_child_left + coeffraf 1779 enddo 1780 else 1781 do k=indmin(3),indmax(3) 1782 do kk=-coeffraf/2+locind_child_left+diffmod, & 1783 coeffraf/2+locind_child_left 1784 do j=indmin(2),indmax(2) 1785 do i=indmin(1),indmax(1) 1786 tempP(i,j,k) = tempP(i,j,k) + tabtemp(i,j,kk) 1787 enddo 1788 enddo 1789 enddo 1790 locind_child_left = locind_child_left + coeffraf 1791 enddo 1792 if (.not.Agrif_Update_Weights) tempP = tempP * invcoeffraf 1793 endif 1713 1794 else 1714 tempP = 0.1715 1795 do j = indmin(2),indmax(2) 1716 1796 do i = indmin(1),indmax(1) … … 1720 1800 s_parent(3),s_child(3), & 1721 1801 ds_parent(3),ds_child(3)) 1722 ! 1802 1723 1803 enddo 1724 1804 enddo 1805 1806 1725 1807 endif 1726 1808 !--------------------------------------------------------------------------------------------------- … … 1734 1816 !! Calls #Agrif_Update_3D_Recursive and #Agrif_UpdateBase. 1735 1817 !--------------------------------------------------------------------------------------------------- 1736 subroutine Agrif_Update_4D_Recursive ( type_update, &1737 tempP, tempC, &1738 indmin, indmax, &1739 lb_child, ub_child, &1740 s_child, s_parent,&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, & 1741 1823 ds_child, ds_parent ) 1742 1824 !--------------------------------------------------------------------------------------------------- … … 1744 1826 integer, dimension(4), intent(in) :: indmin, indmax 1745 1827 integer, dimension(4), intent(in) :: lb_child, ub_child 1746 real , dimension(4), intent(in) :: s_child, s_parent1747 real , dimension(4), intent(in) :: ds_child, ds_parent1828 real(kind=8), dimension(4), intent(in) :: s_child, s_parent 1829 real(kind=8), dimension(4), intent(in) :: ds_child, ds_parent 1748 1830 real, dimension( & 1749 1831 indmin(1):indmax(1), & … … 1755 1837 lb_child(2):ub_child(2), & 1756 1838 lb_child(3):ub_child(3), & 1757 lb_child(4):ub_child(4)), intent(in) :: tempC 1839 lb_child(4):ub_child(4)), intent(in) :: tempC, tempC_indic 1758 1840 !--------------------------------------------------------------------------------------------------- 1759 1841 real, dimension(:,:,:,:), allocatable :: tabtemp … … 1771 1853 indmin(3):indmax(3), l), & 1772 1854 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), & 1773 1858 lb_child(2):ub_child(2), & 1774 1859 lb_child(3):ub_child(3), l), & … … 1806 1891 !! Calls #Agrif_Update_4D_Recursive and #Agrif_UpdateBase. 1807 1892 !--------------------------------------------------------------------------------------------------- 1808 subroutine Agrif_Update_5D_Recursive ( type_update, &1809 tempP, tempC, &1810 indmin, indmax, &1811 lb_child, ub_child, &1812 s_child, s_parent,&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, & 1813 1898 ds_child, ds_parent ) 1814 1899 !--------------------------------------------------------------------------------------------------- … … 1816 1901 integer, dimension(5), intent(in) :: indmin, indmax 1817 1902 integer, dimension(5), intent(in) :: lb_child, ub_child 1818 real , dimension(5), intent(in) :: s_child, s_parent1819 real , dimension(5), intent(in) :: ds_child, ds_parent1903 real(kind=8), dimension(5), intent(in) :: s_child, s_parent 1904 real(kind=8), dimension(5), intent(in) :: ds_child, ds_parent 1820 1905 real, dimension( & 1821 1906 indmin(1):indmax(1), & … … 1829 1914 lb_child(3):ub_child(3), & 1830 1915 lb_child(4):ub_child(4), & 1831 lb_child(5):ub_child(5)), intent(in) :: tempC 1916 lb_child(5):ub_child(5)), intent(in) :: tempC, tempC_indic 1832 1917 !--------------------------------------------------------------------------------------------------- 1833 1918 real, dimension(:,:,:,:,:), allocatable :: tabtemp … … 1847 1932 indmin(4):indmax(4), m), & 1848 1933 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), & 1849 1938 lb_child(2):ub_child(2), & 1850 1939 lb_child(3):ub_child(3), & … … 1885 1974 !! Calls #Agrif_Update_5D_Recursive and #Agrif_UpdateBase. 1886 1975 !--------------------------------------------------------------------------------------------------- 1887 subroutine Agrif_Update_6D_Recursive ( type_update, &1888 tempP, tempC, &1889 indmin, indmax, &1890 lb_child, ub_child, &1891 s_child, s_parent,&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, & 1892 1981 ds_child, ds_parent ) 1893 1982 !--------------------------------------------------------------------------------------------------- … … 1895 1984 integer, dimension(6), intent(in) :: indmin, indmax 1896 1985 integer, dimension(6), intent(in) :: lb_child, ub_child 1897 real , dimension(6), intent(in) :: s_child, s_parent1898 real , dimension(6), intent(in) :: ds_child, ds_parent1986 real(kind=8), dimension(6), intent(in) :: s_child, s_parent 1987 real(kind=8), dimension(6), intent(in) :: ds_child, ds_parent 1899 1988 real, dimension( & 1900 1989 indmin(1):indmax(1), & … … 1910 1999 lb_child(4):ub_child(4), & 1911 2000 lb_child(5):ub_child(5), & 1912 lb_child(6):ub_child(6)), intent(in) :: tempC 2001 lb_child(6):ub_child(6)), intent(in) :: tempC, tempC_indic 1913 2002 !--------------------------------------------------------------------------------------------------- 1914 2003 real, dimension(:,:,:,:,:,:), allocatable :: tabtemp … … 1930 2019 indmin(5):indmax(5), n), & 1931 2020 tempC(lb_child(1):ub_child(1), & 2021 lb_child(2):ub_child(2), & 2022 lb_child(3):ub_child(3), & 2023 lb_child(4):ub_child(4), & 2024 lb_child(5):ub_child(5), n), & 2025 tempC_indic(lb_child(1):ub_child(1), & 1932 2026 lb_child(2):ub_child(2), & 1933 2027 lb_child(3):ub_child(3), & … … 1982 2076 real, dimension(indmin:indmax), intent(out):: parent_tab 1983 2077 real, dimension(lb_child:ub_child), intent(in) :: child_tab 1984 real ,intent(in) :: s_parent, s_child1985 real ,intent(in) :: ds_parent, ds_child2078 real(kind=8), intent(in) :: s_parent, s_child 2079 real(kind=8), intent(in) :: ds_parent, ds_child 1986 2080 !--------------------------------------------------------------------------------------------------- 1987 2081 integer :: np ! Length of parent array -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modupdatebasic.F90
r5656 r10087 49 49 integer, intent(in) :: np !< Length of parent array 50 50 integer, intent(in) :: nc !< Length of child array 51 real ,intent(in) :: s_parent !< Parent grid position (s_root = 0)52 real ,intent(in) :: s_child !< Child grid position (s_root = 0)53 real ,intent(in) :: ds_parent !< Parent grid dx (ds_root = 1)54 real ,intent(in) :: ds_child !< Child grid dx (ds_root = 1)51 real(kind=8), intent(in) :: s_parent !< Parent grid position (s_root = 0) 52 real(kind=8), intent(in) :: s_child !< Child grid position (s_root = 0) 53 real(kind=8), intent(in) :: ds_parent !< Parent grid dx (ds_root = 1) 54 real(kind=8), intent(in) :: ds_child !< Child grid dx (ds_root = 1) 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 ,intent(in) :: s_parent !< Parent grid position (s_root = 0)87 real ,intent(in) :: s_child !< Child grid position (s_root = 0)88 real ,intent(in) :: ds_parent !< Parent grid dx (ds_root = 1)89 real ,intent(in) :: ds_child !< Child grid dx (ds_root = 1)86 real(kind=8), intent(in) :: s_parent !< Parent grid position (s_root = 0) 87 real(kind=8), intent(in) :: s_child !< Child grid position (s_root = 0) 88 real(kind=8), intent(in) :: ds_parent !< Parent grid dx (ds_root = 1) 89 real(kind=8), intent(in) :: ds_child !< Child grid dx (ds_root = 1) 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 ,intent(in) :: s_parent, s_child160 REAL ,intent(in) :: ds_parent, ds_child159 REAL(kind=8), intent(in) :: s_parent, s_child 160 REAL(kind=8), intent(in) :: ds_parent, ds_child 161 161 ! 162 162 INTEGER :: i, ii, locind_child_left, coeffraf 163 REAL :: xpos, invcoeffraf 163 REAL(kind=8) :: xpos 164 REAL :: invcoeffraf 164 165 INTEGER :: nbnonnuls 165 166 INTEGER :: diffmod … … 229 230 !--------------------------------------------------------------------------------------------------- 230 231 INTEGER, intent(in) :: nc2, np, nc 231 REAL , intent(in) :: s_parent, s_child232 REAL , intent(in) :: ds_parent, ds_child232 REAL(kind=8), intent(in) :: s_parent, s_child 233 REAL(kind=8), intent(in) :: ds_parent, ds_child 233 234 INTEGER, intent(in) :: dir 234 235 ! 235 236 INTEGER, DIMENSION(:,:), ALLOCATABLE :: indchildaverage_tmp 236 237 INTEGER :: i, locind_child_left, coeffraf 237 REAL :: xpos238 REAL(kind=8) :: xpos 238 239 INTEGER :: diffmod 239 240 ! … … 281 282 REAL, DIMENSION(nc), intent(in) :: y 282 283 INTEGER, intent(in) :: np, nc 283 REAL , intent(in) :: s_parent, s_child284 REAL , intent(in) :: ds_parent, ds_child284 REAL(kind=8), intent(in) :: s_parent, s_child 285 REAL(kind=8), intent(in) :: ds_parent, ds_child 285 286 INTEGER, intent(in) :: dir 286 287 ! … … 311 312 ELSE 312 313 ! 313 !CDIR NOLOOPCHG 314 do j = 1,coeffraf 315 !CDIR VECTOR 316 do i= 1,np 314 315 do i = 1,np 316 do j = 1,coeffraf 317 317 x(i) = x(i) + y(indchildaverage(i,dir) + j-1 ) 318 318 enddo 319 319 enddo 320 320 IF (.not.Agrif_Update_Weights) THEN … … 338 338 real, dimension(nc), intent(in) :: y 339 339 integer, intent(in) :: np, nc 340 real , intent(in) :: s_parent, s_child341 real , intent(in) :: ds_parent, ds_child342 !--------------------------------------------------------------------------------------------------- 343 REAL :: xpos, xposfin340 real(kind=8), intent(in) :: s_parent, s_child 341 real(kind=8), intent(in) :: ds_parent, ds_child 342 !--------------------------------------------------------------------------------------------------- 343 REAL(kind=8) :: xpos, xposfin 344 344 INTEGER :: i, ii, diffmod 345 345 INTEGER :: it1, it2 -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modutil.F90
r10084 r10087 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- 21 ! Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA. 22 22 ! 23 23 !> Module Agrif_Util 24 !! 25 !! This module contains the two procedures called in the main program : 26 !! - #Agrif_Init_Grids allows the initialization of the root coarse grid 27 !! - #Agrif_Step allows the creation of the grid hierarchy and the management of the time integration. 24 !> 25 !> 26 ! 28 27 ! 29 28 module Agrif_Util 30 29 ! 31 use Agrif_Clustering 32 use Agrif_BcFunction 33 use Agrif_seq 34 use Agrif_Link 30 use Agrif_User_Hierarchy 31 use Agrif_User_Variables 32 use Agrif_user_Functions 33 use Agrif_user_Interpolation 34 use Agrif_user_Update 35 35 36 ! 36 37 implicit none 37 38 ! 38 abstract interface39 subroutine step_proc()40 end subroutine step_proc41 end interface42 !43 39 contains 44 40 ! 45 !===================================================================================================46 ! subroutine Agrif_Step47 !48 !> Creates the grid hierarchy and manages the time integration procedure.49 !> It is called in the main program.50 !> Calls subroutines #Agrif_Regrid and #Agrif_Integrate.51 !---------------------------------------------------------------------------------------------------52 subroutine Agrif_Step ( procname )53 !---------------------------------------------------------------------------------------------------54 procedure(step_proc) :: procname !< subroutine to call on each grid55 type(agrif_grid), pointer :: ref_grid56 !57 ! Set the clustering variables58 call Agrif_clustering_def()59 !60 ! Creation and initialization of the grid hierarchy61 if ( Agrif_USE_ONLY_FIXED_GRIDS == 1 ) then62 !63 if ( (Agrif_Mygrid % ngridstep == 0) .AND. (.not. Agrif_regrid_has_been_done) ) then64 call Agrif_Regrid()65 Agrif_regrid_has_been_done = .TRUE.66 endif67 !68 else69 !70 if (mod(Agrif_Mygrid % ngridstep,Agrif_Regridding) == 0) then71 call Agrif_Regrid()72 endif73 !74 endif75 !76 ! Time integration of the grid hierarchy77 if (agrif_coarse) then78 ref_grid => agrif_coarsegrid79 else80 ref_grid => agrif_mygrid81 endif82 if ( Agrif_Parallel_sisters ) then83 call Agrif_Integrate_Parallel(ref_grid,procname)84 else85 call Agrif_Integrate(ref_grid,procname)86 endif87 !88 if ( ref_grid%child_list%nitems > 0 ) call Agrif_Instance(ref_grid)89 !---------------------------------------------------------------------------------------------------90 end subroutine Agrif_Step91 !===================================================================================================92 !93 !===================================================================================================94 ! subroutine Agrif_Step_Child95 !96 !> Apply 'procname' to each grid of the hierarchy97 !---------------------------------------------------------------------------------------------------98 subroutine Agrif_Step_Child ( procname )99 !---------------------------------------------------------------------------------------------------100 procedure(step_proc) :: procname !< subroutine to call on each grid101 !102 if ( Agrif_Parallel_sisters ) then103 call Agrif_Integrate_Child_Parallel(Agrif_Mygrid,procname)104 else105 call Agrif_Integrate_Child(Agrif_Mygrid,procname)106 endif107 !108 if ( Agrif_Mygrid%child_list%nitems > 0 ) call Agrif_Instance(Agrif_Mygrid)109 !---------------------------------------------------------------------------------------------------110 end subroutine Agrif_Step_Child111 !===================================================================================================112 !113 !===================================================================================================114 ! subroutine Agrif_Regrid115 !116 !> Creates the grid hierarchy from fixed grids and adaptive mesh refinement.117 !---------------------------------------------------------------------------------------------------118 subroutine Agrif_Regrid ( procname )119 !---------------------------------------------------------------------------------------------------120 procedure(init_proc), optional :: procname !< Initialisation subroutine (Default: Agrif_InitValues)121 !122 type(Agrif_Rectangle), pointer :: coarsegrid_fixed123 type(Agrif_Rectangle), pointer :: coarsegrid_moving124 integer :: i, j125 integer :: nunit126 logical :: BEXIST127 TYPE(Agrif_Rectangle) :: newrect ! Pointer on a new grid128 integer :: is_coarse, rhox, rhoy, rhoz, rhot129 !130 if ( Agrif_USE_ONLY_FIXED_GRIDS == 0 ) &131 call Agrif_detect_all(Agrif_Mygrid) ! Detection of areas to be refined132 !133 allocate(coarsegrid_fixed)134 allocate(coarsegrid_moving)135 !136 if ( Agrif_USE_ONLY_FIXED_GRIDS == 0 ) &137 call Agrif_Cluster_All(Agrif_Mygrid,coarsegrid_moving) ! Clustering138 !139 if ( Agrif_USE_FIXED_GRIDS == 1 .OR. Agrif_USE_ONLY_FIXED_GRIDS == 1 ) then140 !141 if (Agrif_Mygrid % ngridstep == 0) then142 !143 nunit = Agrif_Get_Unit()144 open(nunit, file='AGRIF_FixedGrids.in', form='formatted', status="old", ERR=99)145 if (agrif_coarse) then ! SKIP the coarse grid declaration146 if (Agrif_Probdim == 3) then147 read(nunit,*) is_coarse, rhox, rhoy, rhoz, rhot148 elseif (Agrif_Probdim == 2) then149 read(nunit,*) is_coarse, rhox, rhoy, rhot150 elseif (Agrif_Probdim == 2) then151 read(nunit,*) is_coarse, rhox, rhot152 endif153 endif154 ! Creation of the grid hierarchy from the Agrif_FixedGrids.in file155 do i = 1,Agrif_Probdim156 coarsegrid_fixed % imin(i) = 1157 coarsegrid_fixed % imax(i) = Agrif_Mygrid % nb(i) + 1158 enddo159 j = 1160 call Agrif_Read_Fix_Grd(coarsegrid_fixed,j,nunit)161 close(nunit)162 !163 call Agrif_gl_clear(Agrif_oldmygrid)164 !165 ! Creation of the grid hierarchy from coarsegrid_fixed166 call Agrif_Create_Grids(Agrif_Mygrid,coarsegrid_fixed)167 168 else169 call Agrif_gl_copy(Agrif_oldmygrid, Agrif_Mygrid % child_list)170 endif171 else172 call Agrif_gl_copy(Agrif_oldmygrid, Agrif_Mygrid % child_list)173 call Agrif_gl_clear(Agrif_Mygrid % child_list)174 endif175 !176 if ( Agrif_USE_ONLY_FIXED_GRIDS == 0 ) then177 !178 call Agrif_Save_All(Agrif_oldmygrid)179 call Agrif_Free_before_All(Agrif_oldmygrid)180 !181 ! Creation of the grid hierarchy from coarsegrid_moving182 call Agrif_Create_Grids(Agrif_Mygrid,coarsegrid_moving)183 !184 endif185 !186 ! Initialization of the grid hierarchy by copy or interpolation187 !188 #if defined AGRIF_MPI189 if ( Agrif_Parallel_sisters ) then190 call Agrif_Init_Hierarchy_Parallel_1(Agrif_Mygrid)191 call Agrif_Init_Hierarchy_Parallel_2(Agrif_Mygrid,procname)192 else193 call Agrif_Init_Hierarchy(Agrif_Mygrid,procname)194 endif195 #else196 call Agrif_Init_Hierarchy(Agrif_Mygrid,procname)197 #endif198 !199 if ( Agrif_USE_ONLY_FIXED_GRIDS == 0 ) call Agrif_Free_after_All(Agrif_oldmygrid)200 !201 Agrif_regrid_has_been_done = .TRUE.202 !203 call Agrif_Instance( Agrif_Mygrid )204 !205 deallocate(coarsegrid_fixed)206 deallocate(coarsegrid_moving)207 !208 return209 !210 ! Opening error211 !212 99 INQUIRE(FILE='AGRIF_FixedGrids.in',EXIST=BEXIST)213 if (.not. BEXIST) then214 print*,'ERROR : File AGRIF_FixedGrids.in not found.'215 STOP216 else217 print*,'Error opening file AGRIF_FixedGrids.in'218 STOP219 endif220 !---------------------------------------------------------------------------------------------------221 end subroutine Agrif_Regrid222 !===================================================================================================223 !224 !===================================================================================================225 ! subroutine Agrif_detect_All226 !227 !> Detects areas to be refined.228 !---------------------------------------------------------------------------------------------------229 recursive subroutine Agrif_detect_all ( g )230 !---------------------------------------------------------------------------------------------------231 TYPE(Agrif_Grid), pointer :: g !< Pointer on the current grid232 !233 Type(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive procedure234 integer, DIMENSION(3) :: size235 integer :: i236 real :: g_eps237 !238 parcours => g % child_list % first239 !240 ! To be positioned on the finer grids of the grid hierarchy241 !242 do while (associated(parcours))243 call Agrif_detect_all(parcours % gr)244 parcours => parcours % next245 enddo246 !247 g_eps = huge(1.)248 do i = 1,Agrif_Probdim249 g_eps = min(g_eps, g % Agrif_dx(i))250 enddo251 !252 g_eps = g_eps / 100.253 !254 if ( Agrif_Probdim == 1 ) g%tabpoint1D = 0255 if ( Agrif_Probdim == 2 ) g%tabpoint2D = 0256 if ( Agrif_Probdim == 3 ) g%tabpoint3D = 0257 !258 do i = 1,Agrif_Probdim259 if ( g%Agrif_dx(i)/Agrif_coeffref(i) < (Agrif_mind(i)-g_eps) ) return260 enddo261 !262 call Agrif_instance(g)263 !264 ! Detection (Agrif_detect is a users routine)265 !266 do i = 1,Agrif_Probdim267 size(i) = g % nb(i) + 1268 enddo269 !270 SELECT CASE (Agrif_Probdim)271 CASE (1)272 call Agrif_detect(g%tabpoint1D,size)273 CASE (2)274 call Agrif_detect(g%tabpoint2D,size)275 CASE (3)276 call Agrif_detect(g%tabpoint3D,size)277 END SELECT278 !279 ! Addition of the areas detected on the child grids280 !281 parcours => g % child_list % first282 !283 do while (associated(parcours))284 call Agrif_Add_detected_areas(g,parcours % gr)285 parcours => parcours % next286 enddo287 !---------------------------------------------------------------------------------------------------288 end subroutine Agrif_detect_all289 !===================================================================================================290 !291 !===================================================================================================292 ! subroutine Agrif_Add_detected_areas293 !294 !> Adds on the parent grid the areas detected on its child grids295 !---------------------------------------------------------------------------------------------------296 subroutine Agrif_Add_detected_areas ( parentgrid, childgrid )297 !---------------------------------------------------------------------------------------------------298 Type(Agrif_Grid), pointer :: parentgrid299 Type(Agrif_Grid), pointer :: childgrid300 !301 integer :: i,j,k302 !303 do i = 1,childgrid%nb(1)+1304 if ( Agrif_Probdim == 1 ) then305 if (childgrid%tabpoint1D(i)==1) then306 parentgrid%tabpoint1D(childgrid%ix(1)+(i-1)/Agrif_Coeffref(1)) = 1307 endif308 else309 do j=1,childgrid%nb(2)+1310 if (Agrif_Probdim==2) then311 if (childgrid%tabpoint2D(i,j)==1) then312 parentgrid%tabpoint2D( &313 childgrid%ix(1)+(i-1)/Agrif_Coeffref(1), &314 childgrid%ix(2)+(j-1)/Agrif_Coeffref(2)) = 1315 endif316 else317 do k=1,childgrid%nb(3)+1318 if (childgrid%tabpoint3D(i,j,k)==1) then319 parentgrid%tabpoint3D( &320 childgrid%ix(1)+(i-1)/Agrif_Coeffref(1), &321 childgrid%ix(2)+(j-1)/Agrif_Coeffref(2), &322 childgrid%ix(3)+(k-1)/Agrif_Coeffref(3)) = 1323 endif324 enddo325 endif326 enddo327 endif328 enddo329 !---------------------------------------------------------------------------------------------------330 end subroutine Agrif_Add_detected_areas331 !===================================================================================================332 !333 !===================================================================================================334 ! subroutine Agrif_Free_before_All335 !---------------------------------------------------------------------------------------------------336 recursive subroutine Agrif_Free_before_All ( gridlist )337 !---------------------------------------------------------------------------------------------------338 Type(Agrif_Grid_List), intent(inout) :: gridlist !< Grid list339 !340 Type(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive procedure341 !342 parcours => gridlist % first343 !344 do while (associated(parcours))345 !346 if (.not. parcours%gr%fixed) then347 call Agrif_Free_data_before(parcours%gr)348 parcours % gr % oldgrid = .TRUE.349 endif350 !351 call Agrif_Free_before_all (parcours % gr % child_list)352 !353 parcours => parcours % next354 !355 enddo356 !---------------------------------------------------------------------------------------------------357 end subroutine Agrif_Free_before_All358 !===================================================================================================359 !360 !===================================================================================================361 ! subroutine Agrif_Save_All362 !---------------------------------------------------------------------------------------------------363 recursive subroutine Agrif_Save_All ( gridlist )364 !---------------------------------------------------------------------------------------------------365 type(Agrif_Grid_List), intent(inout) :: gridlist !< Grid list366 !367 type(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive procedure368 !369 parcours => gridlist % first370 !371 do while (associated(parcours))372 !373 if (.not. parcours%gr%fixed) then374 call Agrif_Instance(parcours%gr)375 call Agrif_Before_Regridding()376 parcours % gr % oldgrid = .TRUE.377 endif378 !379 call Agrif_Save_All(parcours % gr % child_list)380 !381 parcours => parcours % next382 !383 enddo384 !---------------------------------------------------------------------------------------------------385 end subroutine Agrif_Save_All386 !===================================================================================================387 !388 !===================================================================================================389 ! subroutine Agrif_Free_after_All390 !---------------------------------------------------------------------------------------------------391 recursive subroutine Agrif_Free_after_All ( gridlist )392 !---------------------------------------------------------------------------------------------------393 Type(Agrif_Grid_List), intent(inout) :: gridlist !< Grid list to free394 !395 Type(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive proced396 Type(Agrif_PGrid), pointer :: preparcours397 Type(Agrif_PGrid), pointer :: preparcoursini398 !399 allocate(preparcours)400 !401 preparcoursini => preparcours402 !403 nullify(preparcours % gr)404 !405 preparcours % next => gridlist % first406 parcours => gridlist % first407 !408 do while (associated(parcours))409 !410 if ( (.NOT. parcours%gr % fixed) .AND. (parcours%gr % oldgrid) ) then411 call Agrif_Free_data_after(parcours%gr)412 endif413 !414 call Agrif_Free_after_all( parcours%gr % child_list )415 !416 if (parcours % gr % oldgrid) then417 deallocate(parcours % gr)418 preparcours % next => parcours % next419 deallocate(parcours)420 parcours => preparcours % next421 else422 preparcours => preparcours % next423 parcours => parcours % next424 endif425 !426 enddo427 !428 deallocate(preparcoursini)429 !---------------------------------------------------------------------------------------------------430 end subroutine Agrif_Free_after_All431 !===================================================================================================432 !433 !===================================================================================================434 ! subroutine Agrif_Integrate435 !436 !> Manages the time integration of the grid hierarchy.437 !! Recursive subroutine and call on subroutines Agrif_Init::Agrif_Instance and #Agrif_Step438 !---------------------------------------------------------------------------------------------------439 recursive subroutine Agrif_Integrate ( g, procname )440 !---------------------------------------------------------------------------------------------------441 type(Agrif_Grid), pointer :: g !< Pointer on the current grid442 procedure(step_proc) :: procname !< Subroutine to call on each grid443 !444 type(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive procedure445 integer :: nbt ! Number of time steps of the current grid446 integer :: i, k447 !448 ! Instanciation of the variables of the current grid449 ! if ( g % fixedrank /= 0 ) then450 call Agrif_Instance(g)451 ! endif452 !453 ! One step on the current grid454 !455 call procname ()456 !457 ! Number of time steps on the current grid458 !459 g%ngridstep = g % ngridstep + 1460 parcours => g % child_list % first461 !462 ! Recursive procedure for the time integration of the grid hierarchy463 do while (associated(parcours))464 !465 ! Instanciation of the variables of the current grid466 call Agrif_Instance(parcours % gr)467 !468 ! Number of time steps469 nbt = 1470 do i = 1,Agrif_Probdim471 nbt = max(nbt, parcours % gr % timeref(i))472 enddo473 !474 do k = 1,nbt475 call Agrif_Integrate(parcours % gr, procname)476 enddo477 !478 parcours => parcours % next479 !480 enddo481 !---------------------------------------------------------------------------------------------------482 end subroutine Agrif_Integrate483 !===================================================================================================484 !485 !===================================================================================================486 ! subroutine Agrif_Integrate_Parallel487 !488 !> Manages the time integration of the grid hierarchy in parallel489 !! Recursive subroutine and call on subroutines Agrif_Init::Agrif_Instance and #Agrif_Step490 !---------------------------------------------------------------------------------------------------491 recursive subroutine Agrif_Integrate_Parallel ( g, procname )492 !---------------------------------------------------------------------------------------------------493 type(Agrif_Grid), pointer :: g !< Pointer on the current grid494 procedure(step_proc) :: procname !< Subroutine to call on each grid495 !496 #if defined AGRIF_MPI497 type(Agrif_PGrid), pointer :: gridp ! Pointer for the recursive procedure498 integer :: nbt ! Number of time steps of the current grid499 integer :: i, k, is500 !501 ! Instanciation of the variables of the current grid502 if ( g % fixedrank /= 0 ) then503 call Agrif_Instance(g)504 endif505 !506 ! One step on the current grid507 call procname ()508 !509 ! Number of time steps on the current grid510 g % ngridstep = g % ngridstep + 1511 !512 ! Continue only if the grid has defined sequences of child integrations.513 if ( .not. associated(g % child_seq) ) return514 !515 do is = 1, g % child_seq % nb_seqs516 !517 ! For each sequence, a given processor does integrate only on grid.518 gridp => Agrif_seq_select_child(g,is)519 !520 ! Instanciation of the variables of the current grid521 call Agrif_Instance(gridp % gr)522 !523 ! Number of time steps524 nbt = 1525 do i = 1,Agrif_Probdim526 nbt = max(nbt, gridp % gr % timeref(i))527 enddo528 !529 do k = 1,nbt530 call Agrif_Integrate_Parallel(gridp % gr, procname)531 enddo532 !533 enddo534 #else535 call Agrif_Integrate( g, procname )536 #endif537 !---------------------------------------------------------------------------------------------------538 end subroutine Agrif_Integrate_Parallel539 !===================================================================================================540 !541 !542 !===================================================================================================543 ! subroutine Agrif_Integrate_ChildGrids544 !545 !> Manages the time integration of the grid hierarchy.546 !! Call the subroutine procname on each child grid of the current grid547 !---------------------------------------------------------------------------------------------------548 recursive subroutine Agrif_Integrate_ChildGrids ( procname )549 !---------------------------------------------------------------------------------------------------550 procedure(step_proc) :: procname !< Subroutine to call on each grid551 !552 type(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive procedure553 integer :: nbt ! Number of time steps of the current grid554 integer :: i, k, is555 type(Agrif_Grid) , pointer :: save_grid556 type(Agrif_PGrid), pointer :: gridp ! Pointer for the recursive procedure557 558 save_grid => Agrif_Curgrid559 41 560 ! Number of time steps on the current grid561 save_grid % ngridstep = save_grid % ngridstep + 1562 563 #ifdef AGRIF_MPI564 if ( .not. Agrif_Parallel_sisters ) then565 #endif566 parcours => save_grid % child_list % first567 !568 ! Recursive procedure for the time integration of the grid hierarchy569 do while (associated(parcours))570 !571 ! Instanciation of the variables of the current grid572 call Agrif_Instance(parcours % gr)573 !574 ! Number of time steps575 nbt = 1576 do i = 1,Agrif_Probdim577 nbt = max(nbt, parcours % gr % timeref(i))578 enddo579 !580 do k = 1,nbt581 call procname()582 enddo583 !584 parcours => parcours % next585 !586 enddo587 588 #ifdef AGRIF_MPI589 else590 ! Continue only if the grid has defined sequences of child integrations.591 if ( .not. associated(save_grid % child_seq) ) return592 !593 do is = 1, save_grid % child_seq % nb_seqs594 !595 ! For each sequence, a given processor does integrate only on grid.596 gridp => Agrif_seq_select_child(save_grid,is)597 !598 ! Instanciation of the variables of the current grid599 call Agrif_Instance(gridp % gr)600 !601 ! Number of time steps602 nbt = 1603 do i = 1,Agrif_Probdim604 nbt = max(nbt, gridp % gr % timeref(i))605 enddo606 !607 do k = 1,nbt608 call procname()609 enddo610 !611 enddo612 endif613 #endif614 615 call Agrif_Instance(save_grid)616 617 !---------------------------------------------------------------------------------------------------618 end subroutine Agrif_Integrate_ChildGrids619 !===================================================================================================620 !===================================================================================================621 ! subroutine Agrif_Integrate_Child622 !623 !> Manages the time integration of the grid hierarchy.624 !! Recursive subroutine and call on subroutines Agrif_Instance & Agrif_Step.625 !---------------------------------------------------------------------------------------------------626 recursive subroutine Agrif_Integrate_Child ( g, procname )627 !---------------------------------------------------------------------------------------------------628 type(Agrif_Grid), pointer :: g !< Pointer on the current grid629 procedure(step_proc) :: procname !< Subroutine to call on each grid630 !631 type(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive procedure632 !633 ! One step on the current grid634 !635 call procname ()636 !637 ! Number of time steps on the current grid638 !639 parcours => g % child_list % first640 !641 ! Recursive procedure for the time integration of the grid hierarchy642 do while (associated(parcours))643 !644 ! Instanciation of the variables of the current grid645 call Agrif_Instance(parcours % gr)646 call Agrif_Integrate_Child (parcours % gr, procname)647 parcours => parcours % next648 !649 enddo650 !---------------------------------------------------------------------------------------------------651 end subroutine Agrif_Integrate_Child652 !===================================================================================================653 !654 !===================================================================================================655 ! subroutine Agrif_Integrate_Child_Parallel656 !657 !> Manages the time integration of the grid hierarchy.658 !! Recursive subroutine and call on subroutines Agrif_Instance & Agrif_Step.659 !---------------------------------------------------------------------------------------------------660 recursive subroutine Agrif_Integrate_Child_Parallel ( g, procname )661 !---------------------------------------------------------------------------------------------------662 type(Agrif_Grid), pointer :: g !< Pointer on the current grid663 procedure(step_proc) :: procname !< Subroutine to call on each grid664 !665 #if defined AGRIF_MPI666 type(Agrif_PGrid), pointer :: gridp ! Pointer for the recursive procedure667 integer :: is668 !669 ! Instanciation of the variables of the current grid670 call Agrif_Instance(g)671 !672 ! One step on the current grid673 call procname ()674 !675 ! Continue only if the grid has defined sequences of child integrations.676 if ( .not. associated(g % child_seq) ) return677 !678 do is = 1, g % child_seq % nb_seqs679 !680 ! For each sequence, a given processor does integrate only on grid.681 gridp => Agrif_seq_select_child(g,is)682 call Agrif_Integrate_Child_Parallel(gridp % gr, procname)683 !684 enddo685 !686 call Agrif_Instance(g)687 #else688 call Agrif_Integrate_Child( g, procname )689 #endif690 !---------------------------------------------------------------------------------------------------691 end subroutine Agrif_Integrate_Child_Parallel692 !===================================================================================================693 !694 !===================================================================================================695 ! subroutine Agrif_Init_Grids696 !697 !> Initializes the root coarse grid pointed by Agrif_Mygrid. It is called in the main program.698 !---------------------------------------------------------------------------------------------------699 subroutine Agrif_Init_Grids ( procname1, procname2 )700 !---------------------------------------------------------------------------------------------------701 procedure(typedef_proc), optional :: procname1 !< (Default: Agrif_probdim_modtype_def)702 procedure(alloc_proc), optional :: procname2 !< (Default: Agrif_Allocationcalls)703 !704 integer :: i, ierr_allocate, nunit705 integer :: is_coarse, rhox,rhoy,rhoz,rhot706 logical :: BEXIST707 !708 if (present(procname1)) Then709 call procname1()710 else711 call Agrif_probdim_modtype_def()712 endif713 !714 715 ! TEST FOR COARSE GRID (GRAND MOTHER GRID) in AGRIF_FixedGrids.in716 nunit = Agrif_Get_Unit()717 open(nunit, file='AGRIF_FixedGrids.in', form='formatted', status="old", ERR=98)718 if (Agrif_Probdim == 3) then719 read(nunit,*) is_coarse, rhox, rhoy, rhoz, rhot720 elseif (Agrif_Probdim == 2) then721 read(nunit,*) is_coarse, rhox, rhoy, rhot722 elseif (Agrif_Probdim == 2) then723 read(nunit,*) is_coarse, rhox, rhot724 endif725 if (is_coarse == -1) then726 agrif_coarse = .TRUE.727 if (Agrif_Probdim == 3) then728 coarse_spaceref(1:3)=(/rhox,rhoy,rhoz/)729 elseif (Agrif_Probdim == 2) then730 coarse_spaceref(1:2)=(/rhox,rhoy/)731 elseif (Agrif_Probdim == 2) then732 coarse_spaceref(1:1)=(/rhox/)733 endif734 coarse_timeref(1:Agrif_Probdim) = rhot735 endif736 close(nunit)737 738 Agrif_UseSpecialValue = .FALSE.739 Agrif_UseSpecialValueFineGrid = .FALSE.740 Agrif_SpecialValue = 0.741 Agrif_SpecialValueFineGrid = 0.742 !743 allocate(Agrif_Mygrid)744 allocate(Agrif_OldMygrid)745 !746 ! Space and time refinement factors are set to 1 on the root grid747 !748 do i = 1,Agrif_Probdim749 Agrif_Mygrid % spaceref(i) = coarse_spaceref(i)750 Agrif_Mygrid % timeref(i) = coarse_timeref(i)751 enddo752 !753 ! Initialization of the number of time steps754 Agrif_Mygrid % ngridstep = 0755 Agrif_Mygrid % grid_id = 0756 !757 ! No parent grid for the root coarse grid758 nullify(Agrif_Mygrid % parent)759 !760 ! Initialization of the minimum positions, global abscissa and space steps761 do i = 1, Agrif_Probdim762 Agrif_Mygrid % ix(i) = 1763 Agrif_Mygrid % Agrif_x(i) = 0.764 Agrif_Mygrid % Agrif_dx(i) = 1./Agrif_Mygrid % spaceref(i)765 Agrif_Mygrid % Agrif_dt(i) = 1./Agrif_Mygrid % timeref(i)766 ! Borders of the root coarse grid767 Agrif_Mygrid % NearRootBorder(i) = .true.768 Agrif_Mygrid % DistantRootBorder(i) = .true.769 enddo770 !771 ! The root coarse grid is a fixed grid772 Agrif_Mygrid % fixed = .TRUE.773 ! Level of the root grid774 Agrif_Mygrid % level = 0775 ! Maximum level in the hierarchy776 Agrif_MaxLevelLoc = 0777 !778 ! Number of the grid pointed by Agrif_Mygrid (root coarse grid)779 Agrif_Mygrid % rank = 1780 !781 ! Number of the root grid as a fixed grid782 Agrif_Mygrid % fixedrank = 0783 !784 ! Initialization of some fields of the root grid variables785 ierr_allocate = 0786 if( Agrif_NbVariables(0) > 0 ) allocate(Agrif_Mygrid % tabvars(Agrif_NbVariables(0)),stat=ierr_allocate)787 if( Agrif_NbVariables(1) > 0 ) allocate(Agrif_Mygrid % tabvars_c(Agrif_NbVariables(1)),stat=ierr_allocate)788 if( Agrif_NbVariables(2) > 0 ) allocate(Agrif_Mygrid % tabvars_r(Agrif_NbVariables(2)),stat=ierr_allocate)789 if( Agrif_NbVariables(3) > 0 ) allocate(Agrif_Mygrid % tabvars_l(Agrif_NbVariables(3)),stat=ierr_allocate)790 if( Agrif_NbVariables(4) > 0 ) allocate(Agrif_Mygrid % tabvars_i(Agrif_NbVariables(4)),stat=ierr_allocate)791 if (ierr_allocate /= 0) THEN792 STOP "*** ERROR WHEN ALLOCATING TABVARS ***"793 endif794 !795 ! Initialization of the other fields of the root grid variables (number of796 ! cells, positions, number and type of its dimensions, ...)797 call Agrif_Instance(Agrif_Mygrid)798 call Agrif_Set_numberofcells(Agrif_Mygrid)799 !800 ! Allocation of the array containing the values of the grid variables801 call Agrif_Allocation(Agrif_Mygrid, procname2)802 call Agrif_initialisations(Agrif_Mygrid)803 !804 ! Total number of fixed grids805 Agrif_nbfixedgrids = 0806 807 ! If a grand mother grid is declared808 809 if (agrif_coarse) then810 allocate(Agrif_Coarsegrid)811 812 Agrif_Coarsegrid % ngridstep = 0813 Agrif_Coarsegrid % grid_id = -9999814 815 do i = 1, Agrif_Probdim816 Agrif_Coarsegrid%spaceref(i) = coarse_spaceref(i)817 Agrif_Coarsegrid%timeref(i) = coarse_timeref(i)818 Agrif_Coarsegrid % ix(i) = 1819 Agrif_Coarsegrid % Agrif_x(i) = 0.820 Agrif_Coarsegrid % Agrif_dx(i) = 1.821 Agrif_Coarsegrid % Agrif_dt(i) = 1.822 ! Borders of the root coarse grid823 Agrif_Coarsegrid % NearRootBorder(i) = .true.824 Agrif_Coarsegrid % DistantRootBorder(i) = .true.825 Agrif_Coarsegrid % nb(i) =Agrif_mygrid%nb(i) / coarse_spaceref(i)826 enddo827 828 ! The root coarse grid is a fixed grid829 Agrif_Coarsegrid % fixed = .TRUE.830 ! Level of the root grid831 Agrif_Coarsegrid % level = -1832 833 Agrif_Coarsegrid % grand_mother_grid = .true.834 835 ! Number of the grid pointed by Agrif_Mygrid (root coarse grid)836 Agrif_Coarsegrid % rank = -9999837 !838 ! Number of the root grid as a fixed grid839 Agrif_Coarsegrid % fixedrank = -9999840 841 Agrif_Mygrid%parent => Agrif_Coarsegrid842 843 ! Not used but required to prevent seg fault844 Agrif_Coarsegrid%parent => Agrif_Mygrid845 846 call Agrif_Create_Var(Agrif_Coarsegrid)847 848 ! Reset to null849 Nullify(Agrif_Coarsegrid%parent)850 851 Agrif_Coarsegrid%child_list%nitems = 1852 allocate(Agrif_Coarsegrid%child_list%first)853 allocate(Agrif_Coarsegrid%child_list%last)854 Agrif_Coarsegrid%child_list%first%gr => Agrif_Mygrid855 Agrif_Coarsegrid%child_list%last%gr => Agrif_Mygrid856 857 endif858 859 return860 861 98 INQUIRE(FILE='AGRIF_FixedGrids.in',EXIST=BEXIST)862 if (.not. BEXIST) then863 print*,'ERROR : File AGRIF_FixedGrids.in not found.'864 STOP865 else866 print*,'Error opening file AGRIF_FixedGrids.in'867 STOP868 endif869 870 !---------------------------------------------------------------------------------------------------871 end subroutine Agrif_Init_Grids872 !===================================================================================================873 !874 !===================================================================================================875 ! subroutine Agrif_Deallocation876 !877 !> Deallocates all data arrays.878 !---------------------------------------------------------------------------------------------------879 subroutine Agrif_Deallocation880 !---------------------------------------------------------------------------------------------------881 integer :: nb882 type(Agrif_Variable), pointer :: var883 type(Agrif_Variable_c), pointer :: var_c884 type(Agrif_Variable_l), pointer :: var_l885 type(Agrif_Variable_i), pointer :: var_i886 !887 do nb = 1,Agrif_NbVariables(0)888 !889 var => Agrif_Mygrid % tabvars(nb)890 !891 if ( allocated(var % array1) ) deallocate(var % array1)892 if ( allocated(var % array2) ) deallocate(var % array2)893 if ( allocated(var % array3) ) deallocate(var % array3)894 if ( allocated(var % array4) ) deallocate(var % array4)895 if ( allocated(var % array5) ) deallocate(var % array5)896 if ( allocated(var % array6) ) deallocate(var % array6)897 !898 if ( allocated(var % sarray1) ) deallocate(var % sarray1)899 if ( allocated(var % sarray2) ) deallocate(var % sarray2)900 if ( allocated(var % sarray3) ) deallocate(var % sarray3)901 if ( allocated(var % sarray4) ) deallocate(var % sarray4)902 if ( allocated(var % sarray5) ) deallocate(var % sarray5)903 if ( allocated(var % sarray6) ) deallocate(var % sarray6)904 !905 if ( allocated(var % darray1) ) deallocate(var % darray1)906 if ( allocated(var % darray2) ) deallocate(var % darray2)907 if ( allocated(var % darray3) ) deallocate(var % darray3)908 if ( allocated(var % darray4) ) deallocate(var % darray4)909 if ( allocated(var % darray5) ) deallocate(var % darray5)910 if ( allocated(var % darray6) ) deallocate(var % darray6)911 !912 enddo913 !914 do nb = 1,Agrif_NbVariables(1)915 !916 var_c => Agrif_Mygrid % tabvars_c(nb)917 !918 if ( allocated(var_c % carray1) ) deallocate(var_c % carray1)919 if ( allocated(var_c % carray2) ) deallocate(var_c % carray2)920 !921 enddo922 923 do nb = 1,Agrif_NbVariables(3)924 !925 var_l => Agrif_Mygrid % tabvars_l(nb)926 !927 if ( allocated(var_l % larray1) ) deallocate(var_l % larray1)928 if ( allocated(var_l % larray2) ) deallocate(var_l % larray2)929 if ( allocated(var_l % larray3) ) deallocate(var_l % larray3)930 if ( allocated(var_l % larray4) ) deallocate(var_l % larray4)931 if ( allocated(var_l % larray5) ) deallocate(var_l % larray5)932 if ( allocated(var_l % larray6) ) deallocate(var_l % larray6)933 !934 enddo935 !936 do nb = 1,Agrif_NbVariables(4)937 !938 var_i => Agrif_Mygrid % tabvars_i(nb)939 !940 if ( allocated(var_i % iarray1) ) deallocate(var_i % iarray1)941 if ( allocated(var_i % iarray2) ) deallocate(var_i % iarray2)942 if ( allocated(var_i % iarray3) ) deallocate(var_i % iarray3)943 if ( allocated(var_i % iarray4) ) deallocate(var_i % iarray4)944 if ( allocated(var_i % iarray5) ) deallocate(var_i % iarray5)945 if ( allocated(var_i % iarray6) ) deallocate(var_i % iarray6)946 !947 enddo948 !949 if ( allocated(Agrif_Mygrid % tabvars) ) deallocate(Agrif_Mygrid % tabvars)950 if ( allocated(Agrif_Mygrid % tabvars_c) ) deallocate(Agrif_Mygrid % tabvars_c)951 if ( allocated(Agrif_Mygrid % tabvars_r) ) deallocate(Agrif_Mygrid % tabvars_r)952 if ( allocated(Agrif_Mygrid % tabvars_l) ) deallocate(Agrif_Mygrid % tabvars_l)953 if ( allocated(Agrif_Mygrid % tabvars_i) ) deallocate(Agrif_Mygrid % tabvars_i)954 deallocate(Agrif_Mygrid)955 !---------------------------------------------------------------------------------------------------956 end subroutine Agrif_Deallocation957 !===================================================================================================958 !959 !===================================================================================================960 ! subroutine Agrif_Step_adj961 !962 !> creates the grid hierarchy and manages the backward time integration procedure.963 !> It is called in the main program.964 !> calls subroutines #Agrif_Regrid and #Agrif_Integrate_adj.965 !---------------------------------------------------------------------------------------------------966 subroutine Agrif_Step_adj ( procname )967 !---------------------------------------------------------------------------------------------------968 procedure(step_proc) :: procname !< Subroutine to call on each grid969 !970 ! Creation and initialization of the grid hierarchy971 !972 ! Set the clustering variables973 call Agrif_clustering_def()974 !975 if ( Agrif_USE_ONLY_FIXED_GRIDS .EQ. 1 ) then976 !977 if (Agrif_Mygrid % ngridstep == 0) then978 if (.not.Agrif_regrid_has_been_done ) then979 call Agrif_Regrid()980 endif981 call Agrif_Instance(Agrif_Mygrid)982 endif983 !984 else985 !986 if (mod(Agrif_Mygrid % ngridstep, Agrif_Regridding) == 0) then987 call Agrif_Regrid()988 call Agrif_Instance(Agrif_Mygrid)989 endif990 !991 endif992 !993 ! Time integration of the grid hierarchy994 !995 call Agrif_Integrate_adj (Agrif_Mygrid,procname)996 !997 if ( Agrif_Mygrid % child_list % nitems > 0 ) call Agrif_Instance(Agrif_Mygrid)998 !999 !---------------------------------------------------------------------------------------------------1000 end subroutine Agrif_Step_adj1001 !===================================================================================================1002 !1003 !===================================================================================================1004 ! subroutine Agrif_Integrate_adj1005 !1006 !> Manages the backward time integration of the grid hierarchy.1007 !! Recursive subroutine and call on subroutines Agrif_Init::Agrif_Instance and #Agrif_Step_adj1008 !---------------------------------------------------------------------------------------------------1009 recursive subroutine Agrif_Integrate_adj ( g, procname )1010 !---------------------------------------------------------------------------------------------------1011 type(Agrif_Grid), pointer :: g !< Pointer on the current grid1012 procedure(step_proc) :: procname !< Subroutine to call on each grid1013 !1014 type(Agrif_pgrid), pointer :: parcours ! pointer for the recursive procedure1015 integer :: nbt ! Number of time steps of the current grid1016 integer :: k1017 !1018 ! Instanciation of the variables of the current grid1019 if ( g%fixedrank /= 0 ) then1020 call Agrif_Instance(g)1021 endif1022 !1023 ! Number of time steps on the current grid1024 !1025 g%ngridstep = g % ngridstep + 11026 parcours => g % child_list % first1027 !1028 ! Recursive procedure for the time integration of the grid hierarchy1029 do while (associated(parcours))1030 !1031 ! Instanciation of the variables of the current grid1032 call Agrif_Instance(parcours % gr)1033 !1034 ! Number of time steps1035 nbt = 11036 do k = 1,Agrif_Probdim1037 nbt = max(nbt, parcours % gr % timeref(k))1038 enddo1039 !1040 do k = nbt,1,-11041 call Agrif_Integrate_adj(parcours % gr, procname)1042 enddo1043 !1044 parcours => parcours % next1045 !1046 enddo1047 !1048 if ( g % child_list % nitems > 0 ) call Agrif_Instance(g)1049 !1050 ! One step on the current grid1051 call procname ()1052 !1053 end subroutine Agrif_Integrate_adj1054 !===================================================================================================1055 !1056 !===================================================================================================1057 ! subroutine Agrif_Step_Child_adj1058 !1059 !> Apply 'procname' to each grid of the hierarchy from Child to Parent1060 !---------------------------------------------------------------------------------------------------1061 subroutine Agrif_Step_Child_adj ( procname )1062 !---------------------------------------------------------------------------------------------------1063 procedure(step_proc) :: procname !< Subroutine to call on each grid1064 !1065 call Agrif_Integrate_Child_adj(Agrif_Mygrid,procname)1066 !1067 if ( Agrif_Mygrid % child_list % nitems > 0 ) call Agrif_Instance(Agrif_Mygrid)1068 !1069 end subroutine Agrif_Step_Child_adj1070 !===================================================================================================1071 !1072 !===================================================================================================1073 ! subroutine Agrif_Integrate_Child_adj1074 !1075 !> Manages the backward time integration of the grid hierarchy.1076 !! Recursive subroutine and call on subroutines Agrif_Init::Agrif_Instance & Agrif_Step_adj.1077 !---------------------------------------------------------------------------------------------------1078 recursive subroutine Agrif_Integrate_Child_adj ( g, procname )1079 !---------------------------------------------------------------------------------------------------1080 type(Agrif_Grid),pointer :: g !< Pointer on the current grid1081 procedure(step_proc) :: procname !< Subroutine to call on each grid1082 !1083 type(Agrif_PGrid),pointer :: parcours !< Pointer for the recursive procedure1084 !1085 parcours => g % child_list % first1086 !1087 ! Recursive procedure for the time integration of the grid hierarchy1088 do while (associated(parcours))1089 !1090 ! Instanciation of the variables of the current grid1091 call Agrif_Instance(parcours % gr)1092 call Agrif_Integrate_Child_adj(parcours % gr, procname)1093 !1094 parcours => parcours % next1095 !1096 enddo1097 if ( g % child_list % nitems > 0 ) call Agrif_Instance(g)1098 !1099 ! One step on the current grid1100 call procname()1101 !---------------------------------------------------------------------------------------------------1102 end subroutine Agrif_Integrate_Child_adj1103 !===================================================================================================1104 !1105 !===================================================================================================1106 42 1107 43 end module Agrif_Util -
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modvariables.F90
r5656 r10087 5 5 implicit none 6 6 ! 7 #if defined AGRIF_MPI 8 interface 9 subroutine Agrif_InvLoc ( indloc, proc_id, dir, indglob ) 10 integer, intent(in) :: indloc !< local index 11 integer, intent(in) :: proc_id !< rank of the proc calling this function 12 integer, intent(in) :: dir !< direction of the index 13 integer, intent(out) :: indglob !< global index 14 end subroutine Agrif_InvLoc 15 end interface 16 private :: Agrif_InvLoc 17 #endif 18 7 19 contains 8 20 ! … … 14 26 subroutine Agrif_Declare_Variable ( posvar, firstpoint, raf, lb, ub, varid, torestore ) 15 27 !--------------------------------------------------------------------------------------------------- 16 integer, dimension(:), intent(in):: posvar !< position of the variable on the cell17 !!(1 for the border of the edge, 2 for the center)18 integer, dimension(:), intent(in):: firstpoint !< index of the first point in the real domain19 character( 1), dimension(:), intent(in):: raf !< Array indicating the type of dimension (space or not)20 !!for each of them21 integer, dimension(:), intent(in):: lb !< Lower bounds of the array22 integer, dimension(:), intent(in):: ub !< Upper bounds of the array23 integer, intent(out) :: varid !< Id number of the newly created variable24 logical, optional, intent(in):: torestore !< Indicates if the array restore is used25 ! ---------------------------------------------------------------------------------------------------28 integer, dimension(:), intent(in) :: posvar !< position of the variable on the cell 29 !< (1 for the border of the edge, 2 for the center) 30 integer, dimension(:), intent(in) :: firstpoint !< index of the first point in the real domain 31 character(*), dimension(:), intent(in) :: raf !< Array indicating the type of dimension (space or not) 32 !< for each of them 33 integer, dimension(:), intent(in) :: lb !< Lower bounds of the array 34 integer, dimension(:), intent(in) :: ub !< Upper bounds of the array 35 integer, intent(out) :: varid !< Id number of the newly created variable 36 logical, optional, intent(in) :: torestore !< Indicates if the array restore is used 37 ! 26 38 type(Agrif_Variables_List), pointer :: new_varlist 27 39 type(Agrif_Variable), pointer :: var 28 integer :: nbdim , i40 integer :: nbdim 29 41 logical :: restore 42 #if defined AGRIF_MPI 43 include 'mpif.h' 44 integer :: i 45 integer,dimension(6,2) :: iminmaxg, lubglob 46 integer :: code 47 #endif 30 48 31 49 restore = .FALSE. … … 43 61 allocate(var % posvar(nbdim)) 44 62 allocate(var % interptab(nbdim)) 45 allocate(var % coords(nbdim))46 63 ! 47 var % nbdim = nbdim48 var % interptab = raf(1:nbdim)49 var % posvar = posvar(1:nbdim)50 var % point(1:nbdim) = firstpoint (1:nbdim)64 var % interptab = raf 65 var % nbdim = nbdim 66 var % posvar = posvar 67 var % point(1:nbdim) = firstpoint 51 68 var % restore = restore 52 ! 69 70 var % lb(1:nbdim) = lb(1:nbdim) 71 var % ub(1:nbdim) = ub(1:nbdim) 72 73 #if defined AGRIF_MPI 53 74 do i = 1,nbdim 54 select case( raf(i) ) 55 case('x') ; var % coords(i) = 1 56 case('y') ; var % coords(i) = 2 57 case('z') ; var % coords(i) = 3 58 case('N') ; var % coords(i) = 0 59 case default ; var % coords(i) = 0 60 end select 75 call Agrif_Invloc(lb(i), Agrif_Procrank, i, iminmaxg(i,1)) 76 call Agrif_Invloc(ub(i), Agrif_Procrank, i, iminmaxg(i,2)) 61 77 enddo 62 78 ! 63 var % lb(1:nbdim) = lb(1:nbdim) 64 var % ub(1:nbdim) = ub(1:nbdim) 79 iminmaxg(1:nbdim,2) = - iminmaxg(1:nbdim,2) 80 call MPI_ALLREDUCE(iminmaxg(1:nbdim,:), lubglob(1:nbdim,:), 2*nbdim, MPI_INTEGER,MPI_MIN,Agrif_mpi_comm, code) 81 lubglob(1:nbdim,2) = - lubglob(1:nbdim,2) 82 var % lbglob(1:nbdim) = lubglob(1:nbdim,1) 83 var % ubglob(1:nbdim) = lubglob(1:nbdim,2) 84 #else 85 var % lbglob(1:nbdim) = var % lb(1:nbdim) 86 var % ubglob(1:nbdim) = var % ub(1:nbdim) 87 #endif 65 88 66 89 if ( restore ) then … … 121 144 integer :: nb, varidinv 122 145 ! 123 if ( .not.associated(grid) 146 if ( .not.associated(grid)) then 124 147 outvar => NULL() 125 148 return … … 127 150 ! 128 151 parcours => grid % variables 129 152 130 153 if (.not. associated(parcours)) then ! can occur on the grand mother grid 131 154 outvar => NULL() ! during the first call by agrif_mygrid 132 155 return 133 156 endif 134 157 158 135 159 varidinv = 1 + grid % nbvariables - varid 136 160 … … 140 164 141 165 outvar => parcours % var 166 142 167 !--------------------------------------------------------------------------------------------------- 143 168 end function Agrif_Search_variable
Note: See TracChangeset
for help on using the changeset viewer.