Changeset 10725 for vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modupdate.F90
- Timestamp:
- 2019-02-27T14:55:54+01:00 (5 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modupdate.F90
r10087 r10725 27 27 module Agrif_Update 28 28 ! 29 ! use Agrif_UpdateBasic30 ! use Agrif_Arrays31 ! use Agrif_CurgridFunctions32 ! use Agrif_Mask33 #if defined AGRIF_MPI34 ! use Agrif_Mpp35 #endif36 !37 29 use Agrif_UpdateBasic 38 30 use Agrif_Arrays 39 use Agrif_User_Functions 40 use Agrif_Init 31 use Agrif_CurgridFunctions 41 32 use Agrif_Mask 42 43 33 #if defined AGRIF_MPI 44 34 use Agrif_Mpp … … 68 58 integer, dimension(6) :: ub_child 69 59 integer, dimension(6) :: lb_parent 70 real (kind=8), dimension(6) :: s_child ! Child grid position (s_root = 0)71 real (kind=8), dimension(6) :: s_parent ! Parent grid position (s_root = 0)72 real (kind=8), dimension(6) :: ds_child ! Child grid dx (ds_root = 1)73 real (kind=8), dimension(6) :: ds_parent ! Parent grid dx (ds_root = 1)60 real , dimension(6) :: s_child ! Child grid position (s_root = 0) 61 real , dimension(6) :: s_parent ! Parent grid position (s_root = 0) 62 real , dimension(6) :: ds_child ! Child grid dx (ds_root = 1) 63 real , dimension(6) :: ds_parent ! Parent grid dx (ds_root = 1) 74 64 logical, dimension(6) :: do_update ! Indicates if we perform update for each dimension 75 65 integer, dimension(6) :: posvar ! Position of the variable on the cell (1 or 2) … … 170 160 integer, dimension(nbdim), intent(in) :: posvar !< Position of the variable on the cell (1 or 2) 171 161 logical, dimension(nbdim), intent(in) :: do_update !< Indicates if we update for each dimension 172 real (kind=8), dimension(nbdim), intent(in) :: s_child !< Positions of the child grid173 real (kind=8), dimension(nbdim), intent(in) :: s_parent !< Positions of the parent grid174 real (kind=8), dimension(nbdim), intent(in) :: ds_child !< Space steps of the child grid175 real (kind=8), dimension(nbdim), intent(in) :: ds_parent !< Space steps of the parent grid162 real, dimension(nbdim), intent(in) :: s_child !< Positions of the child grid 163 real, dimension(nbdim), intent(in) :: s_parent !< Positions of the parent grid 164 real, dimension(nbdim), intent(in) :: ds_child !< Space steps of the child grid 165 real, dimension(nbdim), intent(in) :: ds_parent !< Space steps of the parent grid 176 166 procedure() :: procname !< Data recovery procedure 177 167 ! … … 240 230 ! lubglob(:,2) : global lbound for each dimension 241 231 ! 242 ! call Agrif_get_var_global_bounds(child, lubglob, nbdim) 243 lubglob = child % lubglob(1:nbdim,:) 232 call Agrif_get_var_global_bounds(child, lubglob, nbdim) 244 233 ! 245 234 indtruetab(1:nbdim,1,1) = max(indtab(1:nbdim,1,1), lubglob(1:nbdim,1)) … … 285 274 integer, dimension(nbdim), intent(in) :: posvar !< Position of the variable on the cell (1 or 2) 286 275 logical, dimension(nbdim), intent(in) :: do_update !< Indicates if we update for each dimension 287 real (kind=8), dimension(nbdim), intent(in) :: s_child !< Positions of the child grid288 real (kind=8), dimension(nbdim), intent(in) :: s_parent !< Positions of the parent grid289 real (kind=8), dimension(nbdim), intent(in) :: ds_child !< Space steps of the child grid290 real (kind=8), dimension(nbdim), intent(in) :: ds_parent !< Space steps of the parent grid276 real, dimension(nbdim), intent(in) :: s_child !< Positions of the child grid 277 real, dimension(nbdim), intent(in) :: s_parent !< Positions of the parent grid 278 real, dimension(nbdim), intent(in) :: ds_child !< Space steps of the child grid 279 real, dimension(nbdim), intent(in) :: ds_parent !< Space steps of the parent grid 291 280 procedure() :: procname !< Data recovery procedure 292 281 ! … … 411 400 integer, dimension(nbdim), intent(in) :: lb_parent !< Index of the first point inside the domain for the parent 412 401 !! grid variable 413 real (kind=8), dimension(nbdim), intent(in) :: s_child !< Positions of the child grid414 real (kind=8), dimension(nbdim), intent(in) :: s_parent !< Positions of the parent grid415 real (kind=8), dimension(nbdim), intent(in) :: ds_child !< Space steps of the child grid416 real (kind=8), dimension(nbdim), intent(in) :: ds_parent !< Space steps of the parent grid402 real, dimension(nbdim), intent(in) :: s_child !< Positions of the child grid 403 real, dimension(nbdim), intent(in) :: s_parent !< Positions of the parent grid 404 real, dimension(nbdim), intent(in) :: ds_child !< Space steps of the child grid 405 real, dimension(nbdim), intent(in) :: ds_parent !< Space steps of the parent grid 417 406 procedure() :: procname !< Data recovery procedure 418 407 integer, optional, intent(in) :: nb, ndir … … 426 415 integer, dimension(nbdim) :: indmin, indmax 427 416 integer, dimension(nbdim) :: indminglob, indmaxglob 428 real (kind=8), dimension(nbdim) :: s_Child_temp, s_Parent_temp417 real , dimension(nbdim) :: s_Child_temp, s_Parent_temp 429 418 integer, dimension(nbdim) :: lowerbound,upperbound 430 419 integer, dimension(nbdim) :: pttruetabwhole, cetruetabwhole … … 461 450 real :: coeff_multi 462 451 integer :: nb_dimensions 463 464 452 ! 465 453 ! Get local lower and upper bound of the child variable … … 518 506 ! 519 507 call Agrif_array_allocate(tempC,pttruetab,cetruetab,nbdim) 520 #if defined AGRIF_MPI521 508 call Agrif_var_set_array_tozero(tempC,nbdim) 522 #endif523 509 524 510 SELECT CASE (nbdim) … … 615 601 ! 616 602 call Agrif_array_allocate(tempP,indmin,indmax,nbdim) 617 618 IF (Agrif_UseSpecialValueInUpdate) THEN 619 allocate(tempC_indic) 620 allocate(tempP_indic) 621 call Agrif_array_allocate(tempC_indic,pttruetabwhole,cetruetabwhole,nbdim) 622 call Agrif_array_allocate(tempP_indic,indmin,indmax,nbdim) 623 call agrif_set_array_cond(tempCextend,tempC_indic,agrif_SpecialValueFineGrid,nbdim) 624 ELSE 625 tempC_indic=>tempCextend ! Just to associate tempC_indic to something ... 626 ENDIF 627 ! 628 629 603 ! 630 604 if ( nbdim == 1 ) then 631 605 tempP % array1 = 0. … … 633 607 tempP%array1, & 634 608 tempCextend%array1, & 635 tempC_indic%array1, &636 609 indmin(1), indmax(1), & 637 610 pttruetabwhole(1), cetruetabwhole(1), & … … 640 613 641 614 IF (Agrif_UseSpecialValueInUpdate) THEN 615 allocate(tempC_indic) 616 allocate(tempP_indic) 617 call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array1),ubound(tempCextend%array1),nbdim) 618 call Agrif_array_allocate(tempP_indic,lbound(tempP%array1),ubound(tempP%array1),nbdim) 642 619 643 620 compute_average = .FALSE. … … 653 630 tempP_average%array1, & 654 631 tempCextend%array1, & 655 tempC_indic%array1, &656 632 indmin(1), indmax(1), & 657 633 pttruetabwhole(1), cetruetabwhole(1), & … … 664 640 ENDIF 665 641 642 WHERE (tempCextend%array1 == Agrif_SpecialValueFineGrid) 643 tempC_indic%array1 = 0. 644 ELSEWHERE 645 tempC_indic%array1 = 1. 646 END WHERE 647 666 648 Agrif_UseSpecialValueInUpdate = .FALSE. 667 649 Agrif_Update_Weights = .TRUE. … … 669 651 call Agrif_Update_1D_Recursive( type_update_temp(1), & 670 652 tempP_indic%array1, & 671 tempC_indic%array1, &672 653 tempC_indic%array1, & 673 654 indmin(1), indmax(1), & … … 711 692 tempP%array2, & 712 693 tempCextend%array2, & 713 tempC_indic%array2, &714 694 indmin(1:2), indmax(1:2), & 715 695 pttruetabwhole(1:2), cetruetabwhole(1:2), & … … 718 698 719 699 IF (Agrif_UseSpecialValueInUpdate) THEN 700 allocate(tempC_indic) 701 allocate(tempP_indic) 702 call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array2),ubound(tempCextend%array2),nbdim) 703 call Agrif_array_allocate(tempP_indic,lbound(tempP%array2),ubound(tempP%array2),nbdim) 720 704 721 705 compute_average = .FALSE. … … 731 715 tempP_average%array2, & 732 716 tempCextend%array2, & 733 tempC_indic%array2, &734 717 indmin(1:2), indmax(1:2), & 735 718 pttruetabwhole(1:2), cetruetabwhole(1:2), & … … 742 725 ENDIF 743 726 727 WHERE (tempCextend%array2 == Agrif_SpecialValueFineGrid) 728 tempC_indic%array2 = 0. 729 ELSEWHERE 730 tempC_indic%array2 = 1. 731 END WHERE 732 744 733 Agrif_UseSpecialValueInUpdate = .FALSE. 745 734 Agrif_Update_Weights = .TRUE. … … 747 736 call Agrif_Update_2D_Recursive( type_update_temp(1:2), & 748 737 tempP_indic%array2, & 749 tempC_indic%array2, &750 738 tempC_indic%array2, & 751 739 indmin(1:2), indmax(1:2), & … … 786 774 endif 787 775 if ( nbdim == 3 ) then 788 789 776 call Agrif_Update_3D_Recursive( type_update(1:3), & 790 777 tempP%array3, & 791 778 tempCextend%array3, & 792 tempC_indic%array3, &793 779 indmin(1:3), indmax(1:3), & 794 780 pttruetabwhole(1:3), cetruetabwhole(1:3), & 795 781 s_Child_temp(1:3), s_Parent_temp(1:3), & 796 782 ds_child(1:3), ds_parent(1:3) ) 797 798 783 799 784 IF (Agrif_UseSpecialValueInUpdate) THEN 785 allocate(tempC_indic) 786 allocate(tempP_indic) 787 call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array3),ubound(tempCextend%array3),nbdim) 788 call Agrif_array_allocate(tempP_indic,lbound(tempP%array3),ubound(tempP%array3),nbdim) 800 789 801 790 compute_average = .FALSE. … … 808 797 type_update_temp(1:nbdim) = Agrif_Update_Average 809 798 END WHERE 810 811 799 call Agrif_Update_3D_Recursive( type_update_temp(1:3), & 812 800 tempP_average%array3, & 813 801 tempCextend%array3, & 814 tempC_indic%array3, &815 802 indmin(1:3), indmax(1:3), & 816 803 pttruetabwhole(1:3), cetruetabwhole(1:3), & … … 822 809 enddo 823 810 ENDIF 824 811 812 WHERE (tempCextend%array3 == Agrif_SpecialValueFineGrid) 813 tempC_indic%array3 = 0. 814 ELSEWHERE 815 tempC_indic%array3 = 1. 816 END WHERE 817 825 818 Agrif_UseSpecialValueInUpdate = .FALSE. 826 819 Agrif_Update_Weights = .TRUE. 827 828 820 829 821 call Agrif_Update_3D_Recursive( type_update_temp(1:3), & 830 822 tempP_indic%array3, & 831 823 tempC_indic%array3, & 832 tempCextend%array3, &833 824 indmin(1:3), indmax(1:3), & 834 825 pttruetabwhole(1:3), cetruetabwhole(1:3), & … … 836 827 ds_child(1:3), ds_parent(1:3) ) 837 828 838 839 829 Agrif_UseSpecialValueInUpdate = .TRUE. 840 830 Agrif_Update_Weights = .FALSE. 841 831 842 843 832 IF (compute_average) THEN 844 845 833 WHERE (tempP_indic%array3 == 0.) 846 834 tempP%array3 = Agrif_SpecialValueFineGrid … … 850 838 tempP%array3 = tempP_average%array3 /tempP_indic%array3 851 839 END WHERE 852 840 853 841 ELSE 854 842 WHERE (tempP_indic%array3 == 0.) … … 858 846 END WHERE 859 847 ENDIF 860 848 861 849 deallocate(tempP_indic%array3) 862 850 deallocate(tempC_indic%array3) … … 868 856 ENDIF 869 857 ENDIF 870 871 858 872 859 endif 873 860 if ( nbdim == 4 ) then 874 875 861 call Agrif_Update_4D_Recursive( type_update(1:4), & 876 862 tempP%array4, & 877 863 tempCextend%array4, & 878 tempC_indic%array4, &879 864 indmin(1:4), indmax(1:4), & 880 865 pttruetabwhole(1:4), cetruetabwhole(1:4), & 881 866 s_Child_temp(1:4), s_Parent_temp(1:4), & 882 867 ds_child(1:4), ds_parent(1:4) ) 883 868 884 869 IF (Agrif_UseSpecialValueInUpdate) THEN 870 871 allocate(tempC_indic) 872 allocate(tempP_indic) 873 call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array4),ubound(tempCextend%array4),nbdim) 874 call Agrif_array_allocate(tempP_indic,lbound(tempP%array4),ubound(tempP%array4),nbdim) 885 875 886 876 compute_average = .FALSE. … … 896 886 tempP_average%array4, & 897 887 tempCextend%array4, & 898 tempC_indic%array4, &899 888 indmin(1:4), indmax(1:4), & 900 889 pttruetabwhole(1:4), cetruetabwhole(1:4), & … … 907 896 ENDIF 908 897 898 WHERE (tempCextend%array4 == Agrif_SpecialValueFineGrid) 899 tempC_indic%array4 = 0. 900 ELSEWHERE 901 tempC_indic%array4 = 1. 902 END WHERE 903 909 904 Agrif_UseSpecialValueInUpdate = .FALSE. 910 905 Agrif_Update_Weights = .TRUE. … … 912 907 call Agrif_Update_4D_Recursive( type_update_temp(1:4), & 913 908 tempP_indic%array4, & 914 tempC_indic%array4, &915 909 tempC_indic%array4, & 916 910 indmin(1:4), indmax(1:4), & … … 947 941 ENDIF 948 942 ENDIF 949 943 950 944 endif 951 945 if ( nbdim == 5 ) then … … 953 947 tempP%array5, & 954 948 tempCextend%array5, & 955 tempC_indic%array5, &956 949 indmin(1:5), indmax(1:5), & 957 950 pttruetabwhole(1:5), cetruetabwhole(1:5), & … … 960 953 961 954 IF (Agrif_UseSpecialValueInUpdate) THEN 955 allocate(tempC_indic) 956 allocate(tempP_indic) 957 call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array5),ubound(tempCextend%array5),nbdim) 958 call Agrif_array_allocate(tempP_indic,lbound(tempP%array5),ubound(tempP%array5),nbdim) 962 959 963 960 compute_average = .FALSE. … … 973 970 tempP_average%array5, & 974 971 tempCextend%array5, & 975 tempC_indic%array5, &976 972 indmin(1:5), indmax(1:5), & 977 973 pttruetabwhole(1:5), cetruetabwhole(1:5), & … … 984 980 ENDIF 985 981 982 WHERE (tempCextend%array5 == Agrif_SpecialValueFineGrid) 983 tempC_indic%array5 = 0. 984 ELSEWHERE 985 tempC_indic%array5 = 1. 986 END WHERE 987 986 988 Agrif_UseSpecialValueInUpdate = .FALSE. 987 989 Agrif_Update_Weights = .TRUE. … … 989 991 call Agrif_Update_5D_Recursive( type_update_temp(1:5), & 990 992 tempP_indic%array5, & 991 tempC_indic%array5, &992 993 tempC_indic%array5, & 993 994 indmin(1:5), indmax(1:5), & … … 1031 1032 tempP%array6, & 1032 1033 tempCextend%array6, & 1033 tempC_indic%array6, &1034 1034 indmin(1:6), indmax(1:6), & 1035 1035 pttruetabwhole(1:6), cetruetabwhole(1:6), & 1036 1036 s_Child_temp(1:6), s_Parent_temp(1:6), & 1037 1037 ds_child(1:6), ds_parent(1:6) ) 1038 1039 1038 IF (Agrif_UseSpecialValueInUpdate) THEN 1039 allocate(tempC_indic) 1040 allocate(tempP_indic) 1041 call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array6),ubound(tempCextend%array6),nbdim) 1042 call Agrif_array_allocate(tempP_indic,lbound(tempP%array6),ubound(tempP%array6),nbdim) 1040 1043 1041 1044 compute_average = .FALSE. … … 1052 1055 tempP_average%array6, & 1053 1056 tempCextend%array6, & 1054 tempC_indic%array6, &1055 1057 indmin(1:6), indmax(1:6), & 1056 1058 pttruetabwhole(1:6), cetruetabwhole(1:6), & … … 1063 1065 ENDIF 1064 1066 1065 1066 Agrif_UseSpecialValueInUpdate = .FALSE.1067 Agrif_Update_Weights = .TRUE.1068 1069 call Agrif_Update_6D_Recursive( type_update_temp(1:6), &1070 tempP_indic%array6, &1071 tempC_indic%array6, &1072 tempC_indic%array6, &1073 indmin(1:6), indmax(1:6), &1074 pttruetabwhole(1:6), cetruetabwhole(1:6), &1075 s_Child_temp(1:6), s_Parent_temp(1:6), &1076 ds_child(1:6), ds_parent(1:6) )1077 1078 Agrif_UseSpecialValueInUpdate = .TRUE.1079 Agrif_Update_Weights = .FALSE.1080 1081 1067 IF (compute_average) THEN 1082 1068 WHERE (tempP_indic%array6 == 0.) … … 1095 1081 END WHERE 1096 1082 ENDIF 1083 1084 Agrif_UseSpecialValueInUpdate = .FALSE. 1085 Agrif_Update_Weights = .TRUE. 1086 1087 call Agrif_Update_6D_Recursive( type_update_temp(1:6), & 1088 tempP_indic%array6, & 1089 tempC_indic%array6, & 1090 indmin(1:6), indmax(1:6), & 1091 pttruetabwhole(1:6), cetruetabwhole(1:6), & 1092 s_Child_temp(1:6), s_Parent_temp(1:6), & 1093 ds_child(1:6), ds_parent(1:6) ) 1094 1095 Agrif_UseSpecialValueInUpdate = .TRUE. 1096 Agrif_Update_Weights = .FALSE. 1097 1098 WHERE (tempP_indic%array6 == 0.) 1099 tempP%array6 = Agrif_SpecialValueFineGrid 1100 ELSEWHERE 1101 tempP%array6 = tempP%array6 /tempP_indic%array6 1102 END WHERE 1097 1103 1098 1104 deallocate(tempP_indic%array6) … … 1319 1325 integer, intent(in) :: nbdim 1320 1326 integer, dimension(nbdim), intent(out) :: indmin, indmax 1321 real (kind=8), dimension(nbdim), intent(out) :: s_Parent_temp, s_Child_temp1322 real (kind=8), dimension(nbdim), intent(in) :: s_child, ds_child1323 real (kind=8), dimension(nbdim), intent(in) :: s_parent, ds_parent1327 real, dimension(nbdim), intent(out) :: s_Parent_temp, s_Child_temp 1328 real, dimension(nbdim), intent(in) :: s_child, ds_child 1329 real, dimension(nbdim), intent(in) :: s_parent, ds_parent 1324 1330 integer, dimension(nbdim), intent(in) :: pttruetab, cetruetab 1325 1331 integer, dimension(nbdim), intent(in) :: lb_child, lb_parent … … 1331 1337 #endif 1332 1338 ! 1333 real (kind=8),dimension(nbdim) :: dim_newmin,dim_newmax1339 real,dimension(nbdim) :: dim_newmin,dim_newmax 1334 1340 integer :: i 1335 1341 #if defined AGRIF_MPI 1336 real (kind=8):: positionmin, positionmax1342 real :: positionmin, positionmax 1337 1343 integer :: imin, imax 1338 1344 integer :: coeffraf … … 1351 1357 IF ( do_update(i) ) THEN 1352 1358 IF (posvar(i) == 1) THEN 1353 IF (type_update(i) == Agrif_Update_Average) THEN1359 IF ((type_update(i) == Agrif_Update_Average).OR.(type_update(i) == Agrif_Update_Max)) THEN 1354 1360 positionmin = positionmin - ds_parent(i)/2. 1355 1361 ELSE IF (type_update(i) == Agrif_Update_Full_Weighting) THEN … … 1377 1383 IF ( do_update(i) ) THEN 1378 1384 IF (posvar(i) == 1) THEN 1379 IF (type_update(i) == Agrif_Update_Average) THEN1385 IF ((type_update(i) == Agrif_Update_Average).OR.(type_update(i) == Agrif_Update_Max)) THEN 1380 1386 positionmax = positionmax + ds_parent(i)/2. 1381 1387 ELSE IF (type_update(i) == Agrif_Update_Full_Weighting) THEN … … 1418 1424 !> Updates a 1D grid variable on the parent grid 1419 1425 !--------------------------------------------------------------------------------------------------- 1420 subroutine Agrif_Update_1D_Recursive ( type_update, 1421 tempP, tempC, tempC_indic,&1422 indmin, indmax, 1423 lb_child, ub_child, 1424 s_child, s_parent, 1426 subroutine Agrif_Update_1D_Recursive ( type_update, & 1427 tempP, tempC, & 1428 indmin, indmax, & 1429 lb_child, ub_child, & 1430 s_child, s_parent, & 1425 1431 ds_child, ds_parent ) 1426 1432 !--------------------------------------------------------------------------------------------------- … … 1428 1434 integer, intent(in) :: indmin, indmax 1429 1435 integer, intent(in) :: lb_child, ub_child 1430 real (kind=8), intent(in) :: s_child, s_parent1431 real (kind=8), intent(in) :: ds_child, ds_parent1436 real, intent(in) :: s_child, s_parent 1437 real, intent(in) :: ds_child, ds_parent 1432 1438 real, dimension(indmin:indmax), intent(out) :: tempP 1433 real, dimension(lb_child:ub_child), intent(in) :: tempC , tempC_indic1439 real, dimension(lb_child:ub_child), intent(in) :: tempC 1434 1440 !--------------------------------------------------------------------------------------------------- 1435 1441 call Agrif_UpdateBase(type_update, & … … 1450 1456 !! Calls #Agrif_Update_1D_Recursive and #Agrif_UpdateBase 1451 1457 !--------------------------------------------------------------------------------------------------- 1452 subroutine Agrif_Update_2D_Recursive ( type_update, 1453 tempP, tempC, tempC_indic,&1454 indmin, indmax, 1455 lb_child, ub_child, 1456 s_child, s_parent,&1458 subroutine Agrif_Update_2D_Recursive ( type_update, & 1459 tempP, tempC, & 1460 indmin, indmax, & 1461 lb_child, ub_child, & 1462 s_child, s_parent, & 1457 1463 ds_child, ds_parent ) 1458 1464 !--------------------------------------------------------------------------------------------------- … … 1460 1466 integer, dimension(2), intent(in) :: indmin, indmax 1461 1467 integer, dimension(2), intent(in) :: lb_child, ub_child 1462 real (kind=8), dimension(2), intent(in) :: s_child, s_parent1463 real (kind=8), dimension(2), intent(in) :: ds_child, ds_parent1468 real, dimension(2), intent(in) :: s_child, s_parent 1469 real, dimension(2), intent(in) :: ds_child, ds_parent 1464 1470 real, dimension( & 1465 1471 indmin(1):indmax(1), & 1466 1472 indmin(2):indmax(2)), intent(out) :: tempP 1467 real, dimension(:,:), intent(in) :: tempC , tempC_indic1473 real, dimension(:,:), intent(in) :: tempC 1468 1474 !--------------------------------------------------------------------------------------------------- 1469 1475 real, dimension(indmin(1):indmax(1), lb_child(2):ub_child(2)) :: tabtemp … … 1471 1477 real, dimension(lb_child(2):ub_child(2), indmin(1):indmax(1)) :: tabtemp_trsp 1472 1478 integer :: i, j 1473 integer :: coeffraf, coeffraf_2 1474 integer :: jmin,jmax 1475 integer locind_child_left, locind_child_left_2,kuinf 1476 logical :: to_transpose 1477 real :: invcoeffraf 1478 integer :: diffmod, jj,i1,j1 1479 1480 1481 to_transpose = .TRUE. 1482 ! 1483 1479 integer :: coeffraf 1480 ! 1481 tabtemp = 0. 1484 1482 coeffraf = nint ( ds_parent(1) / ds_child(1) ) 1485 1483 ! … … 1494 1492 endif 1495 1493 !---CDIR NEXPAND 1496 tabtemp = 0.1497 1494 call Average1dAfterCompute( tabtemp, tempC, size(tabtemp), size(tempC), & 1498 1495 s_parent(1),s_child(1),ds_parent(1),ds_child(1),1) … … 1508 1505 endif 1509 1506 !---CDIR NEXPAND 1510 1511 1507 call Agrif_basicupdate_copy1d_after(tabtemp,tempC,size(tabtemp),size(tempC),1) 1512 1508 ! 1513 ELSE IF ((coeffraf == 1).AND.(type_update(2) == Agrif_Update_Average)) THEN1514 locind_child_left = 1+agrif_int((s_parent(1)-s_child(1))/ds_child(1))1515 coeffraf_2 = nint ( ds_parent(2) / ds_child(2) )1516 invcoeffraf = 1./coeffraf_21517 tempP = 0.1518 diffmod = 01519 if (mod(coeffraf_2,2) == 0) diffmod = 11520 locind_child_left_2 = 1+agrif_int((s_parent(2)-s_child(2))/ds_child(2))1521 1522 if (Agrif_UseSpecialValueInUpdate) then1523 j1 = -coeffraf_2/2+locind_child_left_2+diffmod1524 do j=indmin(2),indmax(2)1525 do jj=j1,j1+coeffraf_2-11526 i1 = locind_child_left1527 do i=indmin(1),indmax(1)1528 tempP(i,j) = tempP(i,j) + tempC(i1,jj)*tempC_indic(i1,jj)1529 i1 = i1 + 11530 enddo1531 enddo1532 j1 = j1 + coeffraf_21533 enddo1534 else1535 j1 = -coeffraf_2/2+locind_child_left_2+diffmod1536 do j=indmin(2),indmax(2)1537 do jj=j1,j1+coeffraf_2-11538 do i=indmin(1),indmax(1)1539 tempP(i,j) = tempP(i,j) + tempC(locind_child_left+i-indmin(1),jj)1540 enddo1541 enddo1542 j1 = j1 + coeffraf_21543 enddo1544 if (.not.Agrif_Update_Weights) tempP = tempP * invcoeffraf1545 endif1546 return1547 !1548 ELSE IF ((coeffraf == 1).AND.(type_update(2) == Agrif_Update_Copy)) THEN1549 1550 locind_child_left = 1 + agrif_int((s_parent(1)-s_child(1))/ds_child(1))1551 !1552 locind_child_left_2 = 1+nint((s_parent(2)-s_child(2))/ds_child(2))1553 coeffraf_2 = nint ( ds_parent(2) / ds_child(2) )1554 1555 do j=indmin(2),indmax(2)1556 do i=indmin(1),indmax(1)1557 tempP(i,j) = tempC(locind_child_left+i-indmin(1),locind_child_left_2)1558 enddo1559 locind_child_left_2 = locind_child_left_2 + coeffraf_21560 enddo1561 1562 return1563 1564 ELSE IF (coeffraf == 1) THEN1565 locind_child_left = 1 + agrif_int((s_parent(1)-s_child(1))/ds_child(1))1566 !1567 do j = lb_child(2),ub_child(2)1568 ! tabtemp(indmin(1):indmax(1),j) = tempC(locind_child_left:locind_child_left+indmax(1)-indmin(1),j-lb_child(2)+1)1569 tabtemp_trsp(j,indmin(1):indmax(1)) = tempC(locind_child_left:locind_child_left+indmax(1)-indmin(1),j-lb_child(2)+1)1570 enddo1571 to_transpose = .FALSE.1572 1509 ELSE 1573 1510 do j = lb_child(2),ub_child(2) … … 1577 1514 tabtemp(:,j), & 1578 1515 tempC(:,j-lb_child(2)+1), & 1579 tempC_indic(:,j-lb_child(2)+1), &1580 1516 indmin(1), indmax(1), & 1581 1517 lb_child(1),ub_child(1), & … … 1585 1521 ENDIF 1586 1522 ! 1587 1588 if (to_transpose) tabtemp_trsp = TRANSPOSE(tabtemp) 1589 1523 tabtemp_trsp = TRANSPOSE(tabtemp) 1590 1524 coeffraf = nint(ds_parent(2)/ds_child(2)) 1591 1525 ! … … 1632 1566 ENDIF 1633 1567 ! 1634 1635 1636 1568 tempP = TRANSPOSE(tempP_trsp) 1637 1569 !--------------------------------------------------------------------------------------------------- 1638 1570 end subroutine Agrif_Update_2D_Recursive 1571 !=================================================================================================== 1572 ! 1573 subroutine Agrif_Update_2D_Recursive_ok ( type_update, & 1574 tempP, tempC, & 1575 indmin, indmax, & 1576 lb_child, ub_child, & 1577 s_child, s_parent, ds_child, ds_parent ) 1578 !--------------------------------------------------------------------------------------------------- 1579 INTEGER, DIMENSION(2), intent(in) :: type_update !< Type of update (copy or average) 1580 INTEGER, DIMENSION(2), intent(in) :: indmin, indmax 1581 INTEGER, DIMENSION(2), intent(in) :: lb_child, ub_child 1582 REAL, DIMENSION(2), intent(in) :: s_child, s_parent 1583 REAL, DIMENSION(2), intent(in) :: ds_child, ds_parent 1584 REAL, DIMENSION( & 1585 indmin(1):indmax(1), & 1586 indmin(2):indmax(2)), intent(out) :: tempP 1587 REAL, DIMENSION( & 1588 lb_child(1):ub_child(1), & 1589 lb_child(2):ub_child(2)), intent(in) :: tempC 1590 ! 1591 REAL, DIMENSION(indmin(1):indmax(1), lb_child(2):ub_child(2)) :: tabtemp 1592 INTEGER :: i 1593 ! 1594 do i = lb_child(2),ub_child(2) 1595 call Agrif_Update_1D_Recursive(type_update(1), & 1596 tabtemp(:, i), & 1597 tempC(:,i), & 1598 indmin(1),indmax(1), & 1599 lb_child(1),ub_child(1), & 1600 s_child(1), s_parent(1), & 1601 ds_child(1),ds_parent(1)) 1602 enddo 1603 ! 1604 tempP = 0. 1605 ! 1606 do i = indmin(1),indmax(1) 1607 call Agrif_UpdateBase(type_update(2), & 1608 tempP(i,:), & 1609 tabtemp(i,:), & 1610 indmin(2),indmax(2), & 1611 lb_child(2),ub_child(2), & 1612 s_parent(2),s_child(2), & 1613 ds_parent(2),ds_child(2)) 1614 enddo 1615 !--------------------------------------------------------------------------------------------------- 1616 end subroutine Agrif_Update_2D_Recursive_ok 1639 1617 !=================================================================================================== 1640 1618 … … 1646 1624 !! Calls #Agrif_Update_2D_Recursive and #Agrif_UpdateBase. 1647 1625 !--------------------------------------------------------------------------------------------------- 1648 subroutine Agrif_Update_3D_Recursive ( type_update, 1649 tempP, tempC, tempC_indic,&1650 indmin, indmax, 1651 lb_child, ub_child, 1652 s_child, s_parent,&1626 subroutine Agrif_Update_3D_Recursive ( type_update, & 1627 tempP, tempC, & 1628 indmin, indmax, & 1629 lb_child, ub_child, & 1630 s_child, s_parent, & 1653 1631 ds_child, ds_parent ) 1654 1632 !--------------------------------------------------------------------------------------------------- … … 1656 1634 integer, dimension(3), intent(in) :: indmin, indmax 1657 1635 integer, dimension(3), intent(in) :: lb_child, ub_child 1658 real (kind=8), dimension(3), intent(in) :: s_child, s_parent1659 real (kind=8), dimension(3), intent(in) :: ds_child, ds_parent1636 real, dimension(3), intent(in) :: s_child, s_parent 1637 real, dimension(3), intent(in) :: ds_child, ds_parent 1660 1638 real, dimension( & 1661 1639 indmin(1):indmax(1), & … … 1665 1643 lb_child(1):ub_child(1), & 1666 1644 lb_child(2):ub_child(2), & 1667 lb_child(3):ub_child(3)), intent(in) :: tempC , tempC_indic1645 lb_child(3):ub_child(3)), intent(in) :: tempC 1668 1646 !--------------------------------------------------------------------------------------------------- 1669 1647 real, dimension( & … … 1674 1652 integer :: coeffraf,locind_child_left 1675 1653 integer :: kuinf 1676 REAL :: invcoeffraf1677 INTEGER :: diffmod, kk1678 1654 ! 1679 1655 coeffraf = nint ( ds_parent(1) / ds_child(1) ) … … 1713 1689 endif 1714 1690 ! 1715 ! do k = lb_child(3),ub_child(3)1716 ! call Agrif_Update_2D_Recursive( type_update(1:2),tabtemp(:,:,k),tempC(:,:,k), &1717 ! indmin(1:2),indmax(1:2), &1718 ! lb_child(1:2),ub_child(1:2), &1719 ! s_child(1:2),s_parent(1:2), &1720 ! ds_child(1:2),ds_parent(1:2) )1721 ! enddo1722 1723 1724 1691 do k = lb_child(3),ub_child(3) 1725 call Agrif_Update_2D_Recursive( type_update,tabtemp(:,:,k),tempC(:,:,k),tempC_indic(:,:,k), & 1726 indmin,indmax, & 1727 lb_child,ub_child, & 1728 s_child,s_parent, & 1729 ds_child,ds_parent) 1730 enddo 1731 1692 call Agrif_Update_2D_Recursive( type_update(1:2),tabtemp(:,:,k),tempC(:,:,k), & 1693 indmin(1:2),indmax(1:2), & 1694 lb_child(1:2),ub_child(1:2), & 1695 s_child(1:2),s_parent(1:2), & 1696 ds_child(1:2),ds_parent(1:2) ) 1697 enddo 1732 1698 ! 1733 1699 precomputedone(1) = .FALSE. … … 1747 1713 enddo 1748 1714 enddo 1749 else if (type_update(3) == Agrif_Update_Copy) then1750 locind_child_left = lb_child(3) + nint((s_parent(3)-s_child(3))/ds_child(3))1751 1752 do k=indmin(3),indmax(3)1753 do j = indmin(2),indmax(2)1754 do i = indmin(1),indmax(1)1755 tempP(i,j,k) = tabtemp(i,j,locind_child_left)1756 enddo1757 enddo1758 locind_child_left = locind_child_left + coeffraf1759 enddo1760 else if (type_update(3) == Agrif_Update_Average) then1761 invcoeffraf = 1./coeffraf1762 tempP = 0.1763 diffmod = 01764 if (mod(coeffraf,2) == 0) diffmod=11765 locind_child_left = lb_child(3) + agrif_int((s_parent(3)-s_child(3))/ds_child(3))1766 if (Agrif_UseSpecialValueInUpdate) then1767 do k=indmin(3),indmax(3)1768 do kk=-coeffraf/2+locind_child_left+diffmod, &1769 coeffraf/2+locind_child_left1770 do j=indmin(2),indmax(2)1771 do i=indmin(1),indmax(1)1772 if (tabtemp(i,j,kk) /= Agrif_SpecialValueFineGrid) then1773 tempP(i,j,k) = tempP(i,j,k) + tabtemp(i,j,kk)1774 endif1775 enddo1776 enddo1777 enddo1778 locind_child_left = locind_child_left + coeffraf1779 enddo1780 else1781 do k=indmin(3),indmax(3)1782 do kk=-coeffraf/2+locind_child_left+diffmod, &1783 coeffraf/2+locind_child_left1784 do j=indmin(2),indmax(2)1785 do i=indmin(1),indmax(1)1786 tempP(i,j,k) = tempP(i,j,k) + tabtemp(i,j,kk)1787 enddo1788 enddo1789 enddo1790 locind_child_left = locind_child_left + coeffraf1791 enddo1792 if (.not.Agrif_Update_Weights) tempP = tempP * invcoeffraf1793 endif1794 1715 else 1716 tempP = 0. 1795 1717 do j = indmin(2),indmax(2) 1796 1718 do i = indmin(1),indmax(1) … … 1800 1722 s_parent(3),s_child(3), & 1801 1723 ds_parent(3),ds_child(3)) 1802 1724 ! 1803 1725 enddo 1804 1726 enddo 1805 1806 1807 1727 endif 1808 1728 !--------------------------------------------------------------------------------------------------- … … 1816 1736 !! Calls #Agrif_Update_3D_Recursive and #Agrif_UpdateBase. 1817 1737 !--------------------------------------------------------------------------------------------------- 1818 subroutine Agrif_Update_4D_Recursive ( type_update, 1819 tempP, tempC, tempC_indic,&1820 indmin, indmax, 1821 lb_child, ub_child, 1822 s_child, s_parent,&1738 subroutine Agrif_Update_4D_Recursive ( type_update, & 1739 tempP, tempC, & 1740 indmin, indmax, & 1741 lb_child, ub_child, & 1742 s_child, s_parent, & 1823 1743 ds_child, ds_parent ) 1824 1744 !--------------------------------------------------------------------------------------------------- … … 1826 1746 integer, dimension(4), intent(in) :: indmin, indmax 1827 1747 integer, dimension(4), intent(in) :: lb_child, ub_child 1828 real (kind=8), dimension(4), intent(in) :: s_child, s_parent1829 real (kind=8), dimension(4), intent(in) :: ds_child, ds_parent1748 real, dimension(4), intent(in) :: s_child, s_parent 1749 real, dimension(4), intent(in) :: ds_child, ds_parent 1830 1750 real, dimension( & 1831 1751 indmin(1):indmax(1), & … … 1837 1757 lb_child(2):ub_child(2), & 1838 1758 lb_child(3):ub_child(3), & 1839 lb_child(4):ub_child(4)), intent(in) :: tempC , tempC_indic1759 lb_child(4):ub_child(4)), intent(in) :: tempC 1840 1760 !--------------------------------------------------------------------------------------------------- 1841 1761 real, dimension(:,:,:,:), allocatable :: tabtemp … … 1853 1773 indmin(3):indmax(3), l), & 1854 1774 tempC(lb_child(1):ub_child(1), & 1855 lb_child(2):ub_child(2), &1856 lb_child(3):ub_child(3), l), &1857 tempC_indic(lb_child(1):ub_child(1), &1858 1775 lb_child(2):ub_child(2), & 1859 1776 lb_child(3):ub_child(3), l), & … … 1891 1808 !! Calls #Agrif_Update_4D_Recursive and #Agrif_UpdateBase. 1892 1809 !--------------------------------------------------------------------------------------------------- 1893 subroutine Agrif_Update_5D_Recursive ( type_update, 1894 tempP, tempC, tempC_indic,&1895 indmin, indmax, 1896 lb_child, ub_child, 1897 s_child, s_parent,&1810 subroutine Agrif_Update_5D_Recursive ( type_update, & 1811 tempP, tempC, & 1812 indmin, indmax, & 1813 lb_child, ub_child, & 1814 s_child, s_parent, & 1898 1815 ds_child, ds_parent ) 1899 1816 !--------------------------------------------------------------------------------------------------- … … 1901 1818 integer, dimension(5), intent(in) :: indmin, indmax 1902 1819 integer, dimension(5), intent(in) :: lb_child, ub_child 1903 real (kind=8), dimension(5), intent(in) :: s_child, s_parent1904 real (kind=8), dimension(5), intent(in) :: ds_child, ds_parent1820 real, dimension(5), intent(in) :: s_child, s_parent 1821 real, dimension(5), intent(in) :: ds_child, ds_parent 1905 1822 real, dimension( & 1906 1823 indmin(1):indmax(1), & … … 1914 1831 lb_child(3):ub_child(3), & 1915 1832 lb_child(4):ub_child(4), & 1916 lb_child(5):ub_child(5)), intent(in) :: tempC , tempC_indic1833 lb_child(5):ub_child(5)), intent(in) :: tempC 1917 1834 !--------------------------------------------------------------------------------------------------- 1918 1835 real, dimension(:,:,:,:,:), allocatable :: tabtemp … … 1932 1849 indmin(4):indmax(4), m), & 1933 1850 tempC(lb_child(1):ub_child(1), & 1934 lb_child(2):ub_child(2), &1935 lb_child(3):ub_child(3), &1936 lb_child(4):ub_child(4), m), &1937 tempC_indic(lb_child(1):ub_child(1), &1938 1851 lb_child(2):ub_child(2), & 1939 1852 lb_child(3):ub_child(3), & … … 1974 1887 !! Calls #Agrif_Update_5D_Recursive and #Agrif_UpdateBase. 1975 1888 !--------------------------------------------------------------------------------------------------- 1976 subroutine Agrif_Update_6D_Recursive ( type_update, 1977 tempP, tempC, tempC_indic,&1978 indmin, indmax, 1979 lb_child, ub_child, 1980 s_child, s_parent,&1889 subroutine Agrif_Update_6D_Recursive ( type_update, & 1890 tempP, tempC, & 1891 indmin, indmax, & 1892 lb_child, ub_child, & 1893 s_child, s_parent, & 1981 1894 ds_child, ds_parent ) 1982 1895 !--------------------------------------------------------------------------------------------------- … … 1984 1897 integer, dimension(6), intent(in) :: indmin, indmax 1985 1898 integer, dimension(6), intent(in) :: lb_child, ub_child 1986 real (kind=8), dimension(6), intent(in) :: s_child, s_parent1987 real (kind=8), dimension(6), intent(in) :: ds_child, ds_parent1899 real, dimension(6), intent(in) :: s_child, s_parent 1900 real, dimension(6), intent(in) :: ds_child, ds_parent 1988 1901 real, dimension( & 1989 1902 indmin(1):indmax(1), & … … 1999 1912 lb_child(4):ub_child(4), & 2000 1913 lb_child(5):ub_child(5), & 2001 lb_child(6):ub_child(6)), intent(in) :: tempC , tempC_indic1914 lb_child(6):ub_child(6)), intent(in) :: tempC 2002 1915 !--------------------------------------------------------------------------------------------------- 2003 1916 real, dimension(:,:,:,:,:,:), allocatable :: tabtemp … … 2023 1936 lb_child(4):ub_child(4), & 2024 1937 lb_child(5):ub_child(5), n), & 2025 tempC_indic(lb_child(1):ub_child(1), &2026 lb_child(2):ub_child(2), &2027 lb_child(3):ub_child(3), &2028 lb_child(4):ub_child(4), &2029 lb_child(5):ub_child(5), n), &2030 1938 indmin(1:5), indmax(1:5), & 2031 1939 lb_child(1:5),ub_child(1:5), & … … 2076 1984 real, dimension(indmin:indmax), intent(out):: parent_tab 2077 1985 real, dimension(lb_child:ub_child), intent(in) :: child_tab 2078 real (kind=8),intent(in) :: s_parent, s_child2079 real (kind=8),intent(in) :: ds_parent, ds_child1986 real, intent(in) :: s_parent, s_child 1987 real, intent(in) :: ds_parent, ds_child 2080 1988 !--------------------------------------------------------------------------------------------------- 2081 1989 integer :: np ! Length of parent array … … 2101 2009 ds_parent, ds_child ) 2102 2010 ! 2011 elseif ( type_update == Agrif_Update_Max ) then 2012 ! 2013 call Agrif_basicupdate_max1d( & 2014 parent_tab, child_tab, & 2015 np, nc, & 2016 s_parent, s_child, & 2017 ds_parent, ds_child ) 2103 2018 elseif ( type_update == Agrif_Update_Full_Weighting ) then 2104 2019 !
Note: See TracChangeset
for help on using the changeset viewer.
