Changeset 10087 for vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modupdate.F90
- Timestamp:
- 2018-09-05T15:33:44+02:00 (6 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
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
Note: See TracChangeset
for help on using the changeset viewer.
