Changeset 662
- Timestamp:
- 2007-05-25T17:58:52+02:00 (17 years ago)
- Location:
- trunk/AGRIF/AGRIF_FILES
- Files:
-
- 1 added
- 14 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/AGRIF/AGRIF_FILES/modarrays.F
r396 r662 332 332 Variable%array2 = Value 333 333 CASE (3) 334 Variable%array3 = Value 334 Call Agrif_set_tozero3D(Variable%array3) 335 ! Variable%array3 = Value 335 336 CASE (4) 336 337 Variable%array4 = Value … … 343 344 return 344 345 C 345 End Subroutine Agrif_nbdim_Full_VarEQreal 346 End Subroutine Agrif_nbdim_Full_VarEQreal 347 348 Subroutine Agrif_set_tozero3D(tab3D) 349 real,dimension(:,:,:),target :: tab3D 350 351 tab3D = 0. 352 353 end subroutine agrif_set_tozero3D 346 354 C 347 355 C … … 450 458 & Variable2%array1(inf2(1):sup2(1)) 451 459 CASE (2) 452 Variable%array2(inf(1):sup(1), 453 & inf(2):sup(2)) = 454 & Variable2%array2(inf2(1):sup2(1), 455 & inf2(2):sup2(2)) 460 461 Call Agrif_Copy_2d(Variable%array2,Variable2%array2, 462 & lbound(Variable%array2), 463 & lbound(Variable2%array2), 464 & inf,sup,inf2,sup2) 465 456 466 CASE (3) 457 Variable%array3(inf(1):sup(1), 458 & inf(2):sup(2),459 & inf(3):sup(3)) =460 & Variable2%array3(inf2(1):sup2(1),461 & inf2(2):sup2(2),462 & inf2(3):sup2(3)) 467 468 Call Agrif_Copy_3d(Variable%array3,Variable2%array3, 469 & lbound(Variable%array3), 470 & lbound(Variable2%array3), 471 & inf,sup,inf2,sup2) 472 463 473 CASE (4) 464 Variable%array4(inf(1):sup(1), 465 & inf(2):sup(2), 466 & inf(3):sup(3), 467 & inf(4):sup(4)) = 468 & Variable2%array4(inf2(1):sup2(1), 469 & inf2(2):sup2(2), 470 & inf2(3):sup2(3), 471 & inf2(4):sup2(4)) 474 475 Call Agrif_Copy_4d(Variable%array4,Variable2%array4, 476 & lbound(Variable%array4), 477 & lbound(Variable2%array4), 478 & inf,sup,inf2,sup2) 479 472 480 CASE (5) 473 481 Variable%array5(inf(1):sup(1), … … 543 551 C 544 552 C 545 C **************************************************************************546 CCC Subroutine Agrif_array2vector547 C **************************************************************************548 C549 Subroutine Agrif_array2vector(array,bounds,vector,nbdim)550 C551 CCC Description:552 CCC This subroutine is used to record the array into the vector553 C554 C Declarations:555 C556 557 C558 C Arguments559 C560 TYPE(AGRIF_Variable), Pointer :: array561 REAL, DIMENSION(:) :: vector ! Array used for the time562 INTEGER :: nbdim ! dimension of the table563 INTEGER,DIMENSION(nbdim,2) :: bounds564 C565 C Local variables566 C567 INTEGER :: nind,ir,jr,kr,lr,mr,nr568 C569 SELECT CASE (nbdim)570 CASE (1)571 nind=0572 do ir=bounds(1,1),bounds(1,2)573 nind=nind+1574 array%array1(ir) = vector(nind)575 enddo576 C577 CASE (2)578 nind=0579 do jr=bounds(2,1),bounds(2,2)580 do ir=bounds(1,1),bounds(1,2)581 nind=nind+1582 array%array2(ir,jr) = vector(nind)583 enddo584 enddo585 C586 CASE (3)587 nind=0588 do kr=bounds(3,1),bounds(3,2)589 do jr=bounds(2,1),bounds(2,2)590 do ir=bounds(1,1),bounds(1,2)591 nind=nind+1592 array%array3(ir,jr,kr) = vector(nind)593 enddo594 enddo595 enddo596 C597 CASE (4)598 nind=0599 do lr=bounds(4,1),bounds(4,2)600 do kr=bounds(3,1),bounds(3,2)601 do jr=bounds(2,1),bounds(2,2)602 do ir=bounds(1,1),bounds(1,2)603 nind=nind+1604 array%array4(ir,jr,kr,lr) = vector(nind)605 enddo606 enddo607 enddo608 enddo609 C610 CASE (5)611 nind=0612 do mr=bounds(5,1),bounds(5,2)613 do lr=bounds(4,1),bounds(4,2)614 do kr=bounds(3,1),bounds(3,2)615 do jr=bounds(2,1),bounds(2,2)616 do ir=bounds(1,1),bounds(1,2)617 nind=nind+1618 array%array5(ir,jr,kr,lr,mr) = vector(nind)619 enddo620 enddo621 enddo622 enddo623 enddo624 C625 CASE (6)626 nind=0627 do nr=bounds(6,1),bounds(6,2)628 do mr=bounds(5,1),bounds(5,2)629 do lr=bounds(4,1),bounds(4,2)630 do kr=bounds(3,1),bounds(3,2)631 do jr=bounds(2,1),bounds(2,2)632 do ir=bounds(1,1),bounds(1,2)633 nind=nind+1634 array%array6(ir,jr,kr,lr,mr,nr) = vector(nind)635 enddo636 enddo637 enddo638 enddo639 enddo640 enddo641 END SELECT642 C643 return644 C645 End Subroutine Agrif_array2vector646 C647 C648 C649 C **************************************************************************650 CCC Subroutine Agrif_vector2array651 C **************************************************************************652 C653 Subroutine Agrif_vector2array(vector,array,bounds,nbdim)654 C655 CCC Description:656 CCC This subroutine is used to record the array into the vector657 C658 C Declarations:659 C660 661 C662 C Arguments663 C664 TYPE(AGRIF_Variable), Pointer :: array665 REAL, DIMENSION(:) :: vector ! Array used for the time666 INTEGER :: nbdim ! dimension of the table667 INTEGER,DIMENSION(nbdim,2) :: bounds668 C669 C Local variables670 C671 INTEGER :: nind,ir,jr,kr,lr,mr,nr672 C673 SELECT CASE (nbdim)674 CASE (1)675 nind=0676 do ir=bounds(1,1),bounds(1,2)677 nind=nind+1678 vector(nind) = array%array1(ir)679 enddo680 C681 CASE (2)682 nind=0683 do jr=bounds(2,1),bounds(2,2)684 do ir=bounds(1,1),bounds(1,2)685 nind=nind+1686 vector(nind) = array%array2(ir,jr)687 enddo688 enddo689 C690 CASE (3)691 nind=0692 do kr=bounds(3,1),bounds(3,2)693 do jr=bounds(2,1),bounds(2,2)694 do ir=bounds(1,1),bounds(1,2)695 nind=nind+1696 vector(nind) = array%array3(ir,jr,kr)697 enddo698 enddo699 enddo700 C701 CASE (4)702 nind=0703 do lr=bounds(4,1),bounds(4,2)704 do kr=bounds(3,1),bounds(3,2)705 do jr=bounds(2,1),bounds(2,2)706 do ir=bounds(1,1),bounds(1,2)707 nind=nind+1708 vector(nind) = array%array4(ir,jr,kr,lr)709 enddo710 enddo711 enddo712 enddo713 C714 CASE (5)715 nind=0716 do mr=bounds(5,1),bounds(5,2)717 do lr=bounds(4,1),bounds(4,2)718 do kr=bounds(3,1),bounds(3,2)719 do jr=bounds(2,1),bounds(2,2)720 do ir=bounds(1,1),bounds(1,2)721 nind=nind+1722 vector(nind) = array%array5(ir,jr,kr,lr,mr)723 enddo724 enddo725 enddo726 enddo727 enddo728 C729 CASE (6)730 nind=0731 do nr=bounds(6,1),bounds(6,2)732 do mr=bounds(5,1),bounds(5,2)733 do lr=bounds(4,1),bounds(4,2)734 do kr=bounds(3,1),bounds(3,2)735 do jr=bounds(2,1),bounds(2,2)736 do ir=bounds(1,1),bounds(1,2)737 nind=nind+1738 vector(nind) = array%array6(ir,jr,kr,lr,mr,nr)739 enddo740 enddo741 enddo742 enddo743 enddo744 enddo745 END SELECT746 C747 return748 C749 End Subroutine Agrif_vector2array750 553 751 554 #ifdef AGRIF_MPI … … 1310 1113 #ifdef AGRIF_MPI 1311 1114 C 1312 C **************************************************************************1313 CCC Subroutine Agrif_GlobtoLocInd1314 C **************************************************************************1315 C1316 Subroutine Agrif_GlobtoLocInd(tabarray,lboundl,uboundl,tab1,tab2,1317 & nbdim,rank)1318 C1319 CCC Description:1320 CCC For a global index located on the current processor, tabarray gives the1321 CCC corresponding local index1322 C1323 C1324 C Declarations:1325 C1326 1327 C1328 C Arguments1329 INTEGER :: nbdim1330 INTEGER,DIMENSION(nbdim) :: tab1,tab21331 INTEGER,DIMENSION(minval(tab1):maxval(tab2),nbdim,2 ) :: tabarray1332 INTEGER,DIMENSION(nbdim) :: lboundl,uboundl1333 INTEGER :: rank1334 C1335 C Local variables1336 INTEGER :: i,i1,k1337 C1338 C1339 tabarray(:,:,1) = 01340 C1341 do i = 1,nbdim1342 C1343 Call Agrif_Invloc(lboundl(i),rank,i,i1)1344 1345 do k=tab1(i)+lboundl(i)-i1,tab2(i)+lboundl(i)-i11346 tabarray(k-lboundl(i)+i1,i,1)=11347 tabarray(k-lboundl(i)+i1,i,2)=k1348 enddo1349 1350 C1351 enddo1352 C1353 Return1354 C1355 C1356 End Subroutine Agrif_GlobtoLocInd1357 1358 1115 C 1359 1116 C ************************************************************************** … … 1418 1175 #endif 1419 1176 1177 Subroutine Agrif_Copy_2d(tabout,tabin,l,m,inf,sup,inf2,sup2) 1178 integer,dimension(2) :: l,m,inf,sup,inf2,sup2 1179 real,target,dimension(l(1):,l(2):) :: tabout 1180 real,target,dimension(m(1):,m(2):) :: tabin 1181 tabout(inf(1):sup(1), 1182 & inf(2):sup(2)) = 1183 & tabin(inf2(1):sup2(1), 1184 & inf2(2):sup2(2)) 1185 End Subroutine Agrif_Copy_2d 1186 1187 Subroutine Agrif_Copy_3d(tabout,tabin,l,m,inf,sup,inf2,sup2) 1188 integer,dimension(3) :: l,m,inf,sup,inf2,sup2 1189 real,target,dimension(l(1):,l(2):,l(3):) :: tabout 1190 real,target,dimension(m(1):,m(2):,m(3):) :: tabin 1191 tabout(inf(1):sup(1), 1192 & inf(2):sup(2), 1193 & inf(3):sup(3)) = 1194 & tabin(inf2(1):sup2(1), 1195 & inf2(2):sup2(2), 1196 & inf2(3):sup2(3)) 1197 End Subroutine Agrif_Copy_3d 1198 1199 Subroutine Agrif_Copy_4d(tabout,tabin,l,m,inf,sup,inf2,sup2) 1200 integer,dimension(4) :: l,m,inf,sup,inf2,sup2 1201 real,target,dimension(l(1):,l(2):,l(3):,l(4):) :: tabout 1202 real,target,dimension(m(1):,m(2):,m(3):,m(4):) :: tabin 1203 tabout(inf(1):sup(1), 1204 & inf(2):sup(2), 1205 & inf(3):sup(3), 1206 & inf(4):sup(4)) = 1207 & tabin(inf2(1):sup2(1), 1208 & inf2(2):sup2(2), 1209 & inf2(3):sup2(3), 1210 & inf2(4):sup2(4)) 1211 End Subroutine Agrif_Copy_4d 1212 1420 1213 End Module Agrif_Arrays -
trunk/AGRIF/AGRIF_FILES/modbc.F
r572 r662 91 91 childtemp % var % interpIndex => child % var % interpIndex 92 92 childtemp % var % Interpolationshouldbemade = 93 & child % var % Interpolationshouldbemade 93 & child % var % Interpolationshouldbemade 94 childtemp % var % list_interp => child % var% list_interp 94 95 C 95 96 C Call to the procedure for the calculations of the boundary conditions … … 98 99 C 99 100 child % var % oldvalues2D => childtemp % var % oldvalues2D 101 child % var % list_interp => childtemp % var %list_interp 100 102 C 101 103 deallocate(childtemp % var) … … 159 161 childtemp % var % interpIndex => child % var % interpIndex 160 162 childtemp % var % Interpolationshouldbemade = 161 & child % var % Interpolationshouldbemade 163 & child % var % Interpolationshouldbemade 164 childtemp % var % list_interp => child % var% list_interp 162 165 C 163 166 C Call to the procedure for the calculations of the boundary conditions … … 172 175 C 173 176 child % var % oldvalues2D => childtemp % var % oldvalues2D 177 child % var % list_interp => childtemp % var %list_interp 174 178 C 175 179 deallocate(childtemp % var) … … 234 238 childtemp % var % interpIndex => child % var % interpIndex 235 239 childtemp % var % Interpolationshouldbemade = 236 & child % var % Interpolationshouldbemade 240 & child % var % Interpolationshouldbemade 241 childtemp % var % list_interp => child % var% list_interp 237 242 C 238 243 C Call to the procedure for the calculations of the boundary conditions … … 246 251 C 247 252 child % var % oldvalues2D => childtemp % var % oldvalues2D 253 child % var % list_interp => childtemp % var %list_interp 248 254 C 249 255 deallocate(childtemp % var) … … 310 316 childtemp % var % interpIndex => child % var % interpIndex 311 317 childtemp % var % Interpolationshouldbemade = 312 & child % var % Interpolationshouldbemade 318 & child % var % Interpolationshouldbemade 319 childtemp % var % list_interp => child % var% list_interp 313 320 C 314 321 C Call to the procedure for the calculations of the boundary conditions … … 322 329 C 323 330 child % var % oldvalues2D => childtemp % var % oldvalues2D 331 child % var % list_interp => childtemp % var %list_interp 324 332 C 325 333 deallocate(childtemp % var) … … 386 394 childtemp % var % interpIndex => child % var % interpIndex 387 395 childtemp % var % Interpolationshouldbemade = 388 & child % var % Interpolationshouldbemade 396 & child % var % Interpolationshouldbemade 397 childtemp % var % list_interp => child % var% list_interp 389 398 C 390 399 C Call to the procedure for the calculations of the boundary conditions … … 398 407 C 399 408 child % var % oldvalues2D => childtemp % var % oldvalues2D 409 child % var % list_interp => childtemp % var %list_interp 400 410 C 401 411 deallocate(childtemp % var) … … 462 472 childtemp % var % interpIndex => child % var % interpIndex 463 473 childtemp % var % Interpolationshouldbemade = 464 & child % var % Interpolationshouldbemade 474 & child % var % Interpolationshouldbemade 475 childtemp % var % list_interp => child % var% list_interp 465 476 C 466 477 C Call to the procedure for the calculations of the boundary conditions … … 469 480 C 470 481 child % var % oldvalues2D => childtemp % var % oldvalues2D 482 child % var % list_interp => childtemp % var %list_interp 471 483 C 472 484 deallocate(childtemp % var) … … 744 756 ! boundary conditions are 745 757 INTEGER,DIMENSION(nbdim,2,2,nbdim) :: ptres,ptres2 ! calculated 746 INTEGER :: nb,ndir,n,sizetab 758 INTEGER :: nb,ndir,n,sizetab(1) 747 759 REAL, DIMENSION(:), Allocatable :: tab ! Array used for the interpolation 748 INTEGER, DIMENSION(nbdim) :: ztab ! Array used for the interpolation749 760 REAL :: c1t,c2t ! Coefficients for the time interpolation 750 761 ! (c2t=1-c1t) … … 772 783 indtab(1:nbdim,1,2) = indtab(1:nbdim,1,2) - 1 773 784 END WHERE 785 774 786 775 787 #if !defined AGRIF_MPI … … 805 817 indtruetab(1:nbdim,2,2) = min(indtab(1:nbdim,2,2), 806 818 & lubglob(1:nbdim,2)) 807 819 820 808 821 C 809 822 C … … 928 941 C on the parent grid) 929 942 C 930 sizetab = 1 931 ztab(1) = ptres2(1,2,ndir,nb)-ptres2(1,1,ndir,nb)+1 932 C 933 do i = 2,nbdim 943 sizetab(1) = 1 944 C 945 do i = 1,nbdim 934 946 C 935 ztab(i) = ztab(i-1)947 sizetab(1) = sizetab(1) 936 948 & * (ptres2(i,2,ndir,nb)-ptres2(i,1,ndir,nb)+1) 937 949 C 938 950 enddo 939 sizetab=ztab(nbdim) 940 allocate(tab(sizetab)) 941 C 942 Call Agrif_vector2array( 943 & tab,child%var, 944 & ptres2(:,:,ndir,nb), 945 & nbdim) 946 947 C 948 Call saveAfterInterp 949 & (child,tab,kindex) 950 C 951 C 952 deallocate(tab) 951 952 Call saveAfterInterp(child, 953 & ptres2(:,:,ndir,nb),kindex,sizetab(1),nbdim) 954 C 953 955 ENDIF 954 956 C … … 992 994 if (loctab_child(nb) /= (-ndir) 993 995 & .AND. loctab_child(nb) /= -3) then 994 C 995 sizetab=1 996 ztab(1) = ptres2(1,2,ndir,nb)-ptres2(1,1,ndir,nb)+1 997 do i = 2,nbdim 998 C 999 ztab(i) = ztab(i-1) 1000 & * (ptres2(i,2,ndir,nb)-ptres2(i,1,ndir,nb)+1) 1001 C 1002 enddo 1003 C 1004 sizetab = ztab(nbdim) 1005 allocate(tab(sizetab)) 1006 C 1007 Call Agrif_vector2array( 1008 & tab,child%var, 1009 & ptres2(:,:,ndir,nb), 1010 & nbdim) 1011 C 1012 C 996 1013 997 Call timeInterpolation 1014 & (child,tab,kindex,c1t,c2t) 1015 C 1016 C 1017 Call Agrif_array2vector( 1018 & child%var, 1019 & ptres2(:,:,ndir,nb), 1020 & tab,nbdim) 1021 C 1022 C 1023 deallocate(tab) 1024 C 998 & (child,ptres2(:,:,ndir,nb),kindex,c1t,c2t,nbdim) 1025 999 endif 1026 1000 C … … 1039 1013 C ************************************************************************** 1040 1014 C 1041 Subroutine saveAfterInterp(child, tab,kindex)1015 Subroutine saveAfterInterp(child,bounds,kindex,newsize,nbdim) 1042 1016 C 1043 1017 CCC Descritpion: … … 1051 1025 C argument 1052 1026 TYPE (AGRIF_PVariable) :: child ! The fine grid variable 1053 REAL, DIMENSION(:) :: tab ! Values on the fine grid variable1054 ! after the space interpolation1055 1027 INTEGER :: kindex ! Index indicating where this safeguard 1056 1028 ! is done on the fine grid 1029 INTEGER :: nbdim, newsize 1030 INTEGER,DIMENSION(nbdim,2) :: bounds 1057 1031 C 1058 1032 C Local scalars 1059 INTEGER :: newsize ! Size of the domain where boundary 1060 ! conditions are calculated 1061 INTEGER :: i 1033 INTEGER :: ir,jr,kr,lr,mr,nr 1062 1034 C 1063 1035 C 1064 1036 C Allocation of the array oldvalues2d 1065 newsize = size(tab) 1037 1066 1038 C 1067 1039 if (newsize .LE. 0) return 1068 1040 C 1069 Call checkSize1041 Call Agrif_Checksize 1070 1042 & (child,kindex+newsize) 1071 C 1072 C 1073 C Safeguard in the oldvalues2d array 1074 C 1043 1075 1044 if (child % var % interpIndex 1076 1045 & /= Agrif_Curgrid % parent % ngridstep ) then 1077 do i = 1,newsize 1078 child % var % oldvalues2d(kindex,1) = child % var % 1079 & oldvalues2d(kindex,2) 1080 child % var % oldvalues2d(kindex,2) = tab(i) 1081 kindex = kindex + 1 1082 enddo 1083 else 1084 do i = 1,newsize 1085 child % var % oldvalues2d(kindex,2) = tab(i) 1086 kindex = kindex + 1 1087 enddo 1046 child%var%oldvalues2d(kindex:kindex+newsize-1,1)= 1047 & child%var%oldvalues2d(kindex:kindex+newsize-1,2) 1088 1048 endif 1089 1090 1049 1050 SELECT CASE (nbdim) 1051 CASE (1) 1052 1053 do ir=bounds(1,1),bounds(1,2) 1054 child%var%oldvalues2d(kindex,2) = 1055 & child%var%array1(ir) 1056 kindex = kindex + 1 1057 enddo 1058 C 1059 CASE (2) 1060 1061 do jr=bounds(2,1),bounds(2,2) 1062 do ir=bounds(1,1),bounds(1,2) 1063 child%var%oldvalues2d(kindex,2) = 1064 & child%var%array2(ir,jr) 1065 kindex = kindex + 1 1066 enddo 1067 enddo 1068 C 1069 CASE (3) 1070 do kr=bounds(3,1),bounds(3,2) 1071 do jr=bounds(2,1),bounds(2,2) 1072 do ir=bounds(1,1),bounds(1,2) 1073 child%var%oldvalues2d(kindex,2) = 1074 & child%var%array3(ir,jr,kr) 1075 kindex = kindex + 1 1076 enddo 1077 enddo 1078 enddo 1079 C 1080 CASE (4) 1081 do lr=bounds(4,1),bounds(4,2) 1082 do kr=bounds(3,1),bounds(3,2) 1083 do jr=bounds(2,1),bounds(2,2) 1084 do ir=bounds(1,1),bounds(1,2) 1085 child%var%oldvalues2d(kindex,2) = 1086 & child%var%array4(ir,jr,kr,lr) 1087 kindex = kindex + 1 1088 enddo 1089 enddo 1090 enddo 1091 enddo 1092 C 1093 CASE (5) 1094 do mr=bounds(5,1),bounds(5,2) 1095 do lr=bounds(4,1),bounds(4,2) 1096 do kr=bounds(3,1),bounds(3,2) 1097 do jr=bounds(2,1),bounds(2,2) 1098 do ir=bounds(1,1),bounds(1,2) 1099 child%var%oldvalues2d(kindex,2) = 1100 & child%var%array5(ir,jr,kr,lr,mr) 1101 kindex = kindex + 1 1102 enddo 1103 enddo 1104 enddo 1105 enddo 1106 enddo 1107 C 1108 CASE (6) 1109 do nr=bounds(6,1),bounds(6,2) 1110 do mr=bounds(5,1),bounds(5,2) 1111 do lr=bounds(4,1),bounds(4,2) 1112 do kr=bounds(3,1),bounds(3,2) 1113 do jr=bounds(2,1),bounds(2,2) 1114 do ir=bounds(1,1),bounds(1,2) 1115 child%var%oldvalues2d(kindex,2) = 1116 & child%var%array6(ir,jr,kr,lr,mr,nr) 1117 kindex = kindex + 1 1118 enddo 1119 enddo 1120 enddo 1121 enddo 1122 enddo 1123 enddo 1124 END SELECT 1091 1125 C 1092 1126 C … … 1099 1133 C ************************************************************************** 1100 1134 C 1101 Subroutine timeInterpolation(child, tab,kindex,c1t,c2t)1135 Subroutine timeInterpolation(child,bounds,kindex,c1t,c2t,nbdim) 1102 1136 C 1103 1137 CCC Descritpion: … … 1110 1144 C argument 1111 1145 TYPE (AGRIF_PVariable) :: child ! The fine grid variable 1112 REAL, DIMENSION(:) :: tab 1146 INTEGER :: nbdim 1147 INTEGER,DIMENSION(nbdim,2) :: bounds 1113 1148 INTEGER :: kindex ! Index indicating the values of the fine 1114 1149 ! grid got before and after the space … … 1120 1155 C Local aruments 1121 1156 INTEGER :: i 1122 C 1123 C 1124 do i = 1,size(tab) 1125 tab(i) = c2t*child % var % oldvalues2d(kindex,1) 1126 & + c1t*child % var % oldvalues2d(kindex,2) 1127 kindex = kindex + 1 1128 enddo 1157 C Local scalars 1158 INTEGER :: ir,jr,kr,lr,mr,nr 1159 C 1160 C 1161 1162 SELECT CASE (nbdim) 1163 CASE (1) 1164 1165 do ir=bounds(1,1),bounds(1,2) 1166 child%var%array1(ir) = 1167 & c2t*child % var % oldvalues2d(kindex,1) 1168 & + c1t*child % var % oldvalues2d(kindex,2) 1169 kindex = kindex + 1 1170 enddo 1171 C 1172 CASE (2) 1173 1174 do jr=bounds(2,1),bounds(2,2) 1175 do ir=bounds(1,1),bounds(1,2) 1176 child%var%array2(ir,jr) = 1177 & c2t*child % var % oldvalues2d(kindex,1) 1178 & + c1t*child % var % oldvalues2d(kindex,2) 1179 kindex = kindex + 1 1180 enddo 1181 enddo 1182 C 1183 CASE (3) 1184 do kr=bounds(3,1),bounds(3,2) 1185 do jr=bounds(2,1),bounds(2,2) 1186 do ir=bounds(1,1),bounds(1,2) 1187 child%var%array3(ir,jr,kr) = 1188 & c2t*child % var % oldvalues2d(kindex,1) 1189 & + c1t*child % var % oldvalues2d(kindex,2) 1190 kindex = kindex + 1 1191 enddo 1192 enddo 1193 enddo 1194 C 1195 CASE (4) 1196 do lr=bounds(4,1),bounds(4,2) 1197 do kr=bounds(3,1),bounds(3,2) 1198 do jr=bounds(2,1),bounds(2,2) 1199 do ir=bounds(1,1),bounds(1,2) 1200 child%var%array4(ir,jr,kr,lr) = 1201 & c2t*child % var % oldvalues2d(kindex,1) 1202 & + c1t*child % var % oldvalues2d(kindex,2) 1203 kindex = kindex + 1 1204 enddo 1205 enddo 1206 enddo 1207 enddo 1208 C 1209 CASE (5) 1210 do mr=bounds(5,1),bounds(5,2) 1211 do lr=bounds(4,1),bounds(4,2) 1212 do kr=bounds(3,1),bounds(3,2) 1213 do jr=bounds(2,1),bounds(2,2) 1214 do ir=bounds(1,1),bounds(1,2) 1215 child%var%array5(ir,jr,kr,lr,mr) = 1216 & c2t*child % var % oldvalues2d(kindex,1) 1217 & + c1t*child % var % oldvalues2d(kindex,2) 1218 kindex = kindex + 1 1219 enddo 1220 enddo 1221 enddo 1222 enddo 1223 enddo 1224 C 1225 CASE (6) 1226 do nr=bounds(6,1),bounds(6,2) 1227 do mr=bounds(5,1),bounds(5,2) 1228 do lr=bounds(4,1),bounds(4,2) 1229 do kr=bounds(3,1),bounds(3,2) 1230 do jr=bounds(2,1),bounds(2,2) 1231 do ir=bounds(1,1),bounds(1,2) 1232 child%var%array6(ir,jr,kr,lr,mr,nr) = 1233 & c2t*child % var % oldvalues2d(kindex,1) 1234 & + c1t*child % var % oldvalues2d(kindex,2) 1235 kindex = kindex + 1 1236 enddo 1237 enddo 1238 enddo 1239 enddo 1240 enddo 1241 enddo 1242 END SELECT 1243 1129 1244 C 1130 1245 C … … 1134 1249 C 1135 1250 C ************************************************************************** 1136 CCC Subroutine checkSize1137 C ************************************************************************** 1138 C 1139 Subroutine checkSize(child,newsize)1251 CCC Subroutine Agrif_Checksize 1252 C ************************************************************************** 1253 C 1254 Subroutine Agrif_Checksize(child,newsize) 1140 1255 C 1141 1256 CCC Descritpion: … … 1189 1304 C 1190 1305 C 1191 End Subroutine checkSize1306 End Subroutine Agrif_Checksize 1192 1307 C 1193 1308 C -
trunk/AGRIF/AGRIF_FILES/modbcfunction.F
r396 r662 34 34 Use Agrif_Boundary 35 35 Use Agrif_Update 36 Use Agrif_fluxmod 36 37 C 37 38 IMPLICIT NONE … … 109 110 dimensio = Agrif_Mygrid % tabvars(tabvarsindic) %var % nbdim 110 111 C 112 if (.not.associated(Agrif_Mygrid % tabvars(tabvarsindic) 113 & %var % posvar)) then 111 114 Allocate( 112 115 & Agrif_Mygrid % tabvars(tabvarsindic)%var % posvar(dimensio)) 113 116 endif 117 114 118 do i = 1 , dimensio 115 119 Agrif_Mygrid % tabvars(tabvarsindic) %var % posvar(i) … … 214 218 C 215 219 dimensio = Agrif_Mygrid % tabvars(tabvarsindic) %var % nbdim 216 C 220 C 221 if (.not.associated(Agrif_Mygrid % tabvars(tabvarsindic) 222 & %var % interptab)) then 217 223 Allocate( 218 224 & Agrif_Mygrid % tabvars(tabvarsindic)%var% interptab(dimensio)) 225 endif 219 226 220 227 do i = 1 , dimensio … … 254 261 C 255 262 C 256 if (Agrif_Curgrid % fixedrank .NE. 0) then 257 allocate(Agrif_Curgrid%tabvars(tabvarsindic)%var % interpIndex) 258 Agrif_Curgrid%tabvars(tabvarsindic)%var % interpIndex = -1 259 if ( PRESENT(Interpolationshouldbemade) ) then 263 if (Agrif_Curgrid % fixedrank .NE. 0) then 264 IF (.Not.Associated(Agrif_Curgrid%tabvars(tabvarsindic)%var 265 & % interpIndex)) THEN 266 Allocate(Agrif_Curgrid%tabvars(tabvarsindic)%var % interpIndex) 267 Agrif_Curgrid%tabvars(tabvarsindic)%var % interpIndex = -1 268 269 Allocate( 270 & Agrif_Curgrid%tabvars(tabvarsindic)%var % oldvalues2D(1,2)) 271 Agrif_Curgrid%tabvars(tabvarsindic)%var % oldvalues2D = 0. 272 ENDIF 273 if ( PRESENT(Interpolationshouldbemade) ) then 260 274 Agrif_Curgrid%tabvars(tabvarsindic)%var % 261 275 & Interpolationshouldbemade = Interpolationshouldbemade 262 endif 263 Allocate( 264 & Agrif_Curgrid%tabvars(tabvarsindic)%var % oldvalues2D(1,2)) 265 Agrif_Curgrid%tabvars(tabvarsindic)%var % oldvalues2D = 0. 276 endif 277 266 278 endif 267 279 C … … 591 603 & weight,pweight,procname) 592 604 ELSE 605 593 606 Call Agrif_Interp_Bc_2D( 594 607 & Agrif_Mygrid % tabvars(tabvarsindic) % var % bctypeinterp, … … 1418 1431 1419 1432 Return 1420 End Subroutine Agrif_update_var5d 1433 End Subroutine Agrif_update_var5d 1434 1435 Subroutine Agrif_Declare_Flux(fluxname,profilename) 1436 character*(*) :: fluxname, profilename 1437 Type(Agrif_Flux), pointer :: newflux 1438 Type(Agrif_Profile), pointer :: parcours 1439 logical :: foundprofile 1440 integer :: i,j,n 1441 1442 foundprofile = .FALSE. 1443 parcours => Agrif_Myprofiles 1444 1445 Do While (Associated(parcours)) 1446 IF (parcours % profilename == profilename) THEN 1447 foundprofile = .TRUE. 1448 EXIT 1449 ENDIF 1450 parcours => parcours%nextprofile 1451 End Do 1452 1453 IF (.NOT.foundprofile) THEN 1454 write(*,*) 'The profile ''' 1455 & //TRIM(profilename)//''' has not been declared' 1456 stop 1457 ENDIF 1458 1459 print *,'ici' 1460 Allocate(Newflux) 1461 1462 Newflux % fluxname = fluxname 1463 1464 Newflux % profile => parcours 1465 1466 Newflux % nextflux => Agrif_Curgrid % fluxes 1467 1468 Agrif_Curgrid % fluxes => Newflux 1469 1470 End Subroutine Agrif_Declare_Flux 1471 1472 Subroutine Agrif_Save_Flux(fluxname, fluxtab) 1473 character*(*) :: fluxname 1474 REAL, DIMENSION(:,:) :: fluxtab 1475 1476 1477 Type(Agrif_Flux), pointer :: Flux 1478 1479 Type(Agrif_pgrid), pointer :: parcours_child 1480 1481 Type(Agrif_grid), Pointer :: currentgrid,oldcurgrid 1482 1483 IF (.Not.Agrif_Root()) THEN 1484 Flux => Agrif_Search_Flux(fluxname) 1485 1486 IF (.NOT.Flux%fluxallocated) THEN 1487 CALL Agrif_AllocateFlux(Flux,fluxtab) 1488 ENDIF 1489 1490 Call Agrif_Save_Fluxtab(Flux,fluxtab) 1491 1492 ENDIF 1493 1494 oldcurgrid=> Agrif_Curgrid 1495 1496 parcours_child => Agrif_Curgrid%child_grids 1497 1498 Do While (Associated(parcours_child)) 1499 currentgrid => parcours_child%gr 1500 Agrif_Curgrid => parcours_child%gr 1501 Flux => Agrif_Search_Flux(fluxname) 1502 IF (.NOT.Flux%fluxallocated) THEN 1503 CALL Agrif_AllocateFlux(Flux,fluxtab) 1504 ENDIF 1505 Call Agrif_Save_Fluxtab_child(Flux,fluxtab) 1506 parcours_child=> parcours_child%next 1507 End Do 1508 1509 Agrif_Curgrid=>oldcurgrid 1510 1511 End Subroutine Agrif_Save_Flux 1512 1513 Subroutine Agrif_Cancel_Flux(fluxname) 1514 character*(*) :: fluxname 1515 1516 Type(Agrif_Flux), pointer :: Flux 1517 1518 Flux => Agrif_Search_Flux(fluxname) 1519 1520 IF (Flux%FluxAllocated) Call Agrif_Cancel_Fluxarray(Flux) 1521 1522 End Subroutine Agrif_Cancel_Flux 1523 1524 Subroutine Agrif_Flux_Correction(fluxname, procname) 1525 character*(*) :: fluxname 1526 external :: procname 1527 1528 Type(Agrif_Flux), pointer :: Flux 1529 1530 Flux => Agrif_Search_Flux(fluxname) 1531 1532 Call Agrif_FluxCorrect(Flux, procname) 1533 1534 1535 End Subroutine Agrif_Flux_Correction 1536 1537 Subroutine Agrif_Declare_Profile(profilename,posvar,firstpoint, 1538 & raf) 1539 character*(*) :: profilename 1540 Type(Agrif_Profile), Pointer :: newprofile 1541 INTEGER, DIMENSION(:) :: posvar 1542 INTEGER, DIMENSION(:) :: firstpoint 1543 CHARACTER(*) ,DIMENSION(:) :: raf 1544 INTEGER :: dimensio 1545 1546 dimensio = SIZE(posvar) 1547 C 1548 C 1549 Allocate(newprofile) 1550 Allocate(newprofile%posvar(dimensio)) 1551 Allocate(newprofile%interptab(dimensio)) 1552 newprofile%profilename = profilename 1553 newprofile%interptab = raf 1554 newprofile%nbdim = dimensio 1555 newprofile%posvar = posvar 1556 newprofile%point(1:dimensio) = firstpoint 1557 1558 newprofile % nextprofile => Agrif_myprofiles 1559 1560 Agrif_myprofiles => newprofile 1561 1562 End Subroutine Agrif_Declare_Profile 1563 1421 1564 C 1422 1565 End module Agrif_bcfunction -
trunk/AGRIF/AGRIF_FILES/modcluster.F
r396 r662 131 131 C 132 132 C Recursive call to Agrif_Cluster_All 133 Call Agrif_Cluster_All (newgrid, parcours % r) 133 Call Agrif_Cluster_All (newgrid, parcours % r) 134 134 C 135 135 parcours => parcours % next … … 574 574 C coefficient 1.05 avant 1.15 possibilité de laisser choix à l utilisateur 575 575 if (REAL(nbpointsflag)/REAL(nbpoints) 576 & .LT.(1.0 5*cureff)) then576 & .LT.(1.0001*cureff)) then 577 577 parcbox2 => boxlib 578 578 do While (associated(parcbox2)) -
trunk/AGRIF/AGRIF_FILES/modcurgridfunctions.F
r396 r662 779 779 C 780 780 End Function Agrif_Get_Unit 781 782 Subroutine Agrif_Set_Efficiency(eff) 783 REAL :: eff 784 785 IF ((eff.LT.0.).OR.(eff.GT.1)) THEN 786 write(*,*)'Error Efficiency should be between 0 and 1' 787 stop 788 ELSE 789 Agrif_efficiency = eff 790 ENDIF 791 End Subroutine Agrif_Set_Efficiency 792 793 Subroutine Agrif_Set_Regridding(regfreq) 794 INTEGER :: regfreq 795 796 IF (regfreq.LT.0) THEN 797 write(*,*)'Regridding frequency should be positive' 798 stop 799 ELSE 800 Agrif_regridding = regfreq 801 ENDIF 802 End Subroutine Agrif_Set_Regridding 781 803 C 782 804 End Module Agrif_CurgridFunctions -
trunk/AGRIF/AGRIF_FILES/modinterp.F
r396 r662 104 104 childtemp % var % interpIndex => child % var % interpIndex 105 105 childtemp % var % Interpolationshouldbemade = 106 & child % var % Interpolationshouldbemade 106 & child % var % Interpolationshouldbemade 107 childtemp % var % list_interp => child % var% list_interp 107 108 C 108 109 Call Agrif_InterpVariable 109 110 & (TypeInterp,parent,childtemp,torestore) 111 child % var % list_interp => childtemp % var %list_interp 110 112 C 111 113 deallocate(childtemp % var) … … 173 175 childtemp % var % interpIndex => child % var % interpIndex 174 176 childtemp % var % Interpolationshouldbemade = 175 & child % var % Interpolationshouldbemade 177 & child % var % Interpolationshouldbemade 178 childtemp % var % list_interp => child % var% list_interp 176 179 C 177 180 Call Agrif_InterpVariable 178 181 & (TypeInterp,parent,childtemp,torestore) 182 child % var % list_interp => childtemp % var %list_interp 179 183 C 180 184 deallocate(childtemp % var) … … 243 247 childtemp % var % interpIndex => child % var % interpIndex 244 248 childtemp % var % Interpolationshouldbemade = 245 & child % var % Interpolationshouldbemade 249 & child % var % Interpolationshouldbemade 250 childtemp % var % list_interp => child % var% list_interp 246 251 C 247 252 Call Agrif_InterpVariable 248 253 & (TypeInterp,parent,childtemp,torestore) 254 child % var % list_interp => childtemp % var %list_interp 249 255 C 250 256 deallocate(childtemp % var) … … 314 320 childtemp % var % interpIndex => child % var % interpIndex 315 321 childtemp % var % Interpolationshouldbemade = 316 & child % var % Interpolationshouldbemade 322 & child % var % Interpolationshouldbemade 323 childtemp % var % list_interp => child % var% list_interp 317 324 C 318 325 Call Agrif_InterpVariable 319 326 & (TypeInterp,parent,childtemp,torestore) 327 child % var % list_interp => childtemp % var %list_interp 320 328 C 321 329 deallocate(childtemp % var) … … 386 394 childtemp % var % interpIndex => child % var % interpIndex 387 395 childtemp % var % Interpolationshouldbemade = 388 & child % var % Interpolationshouldbemade 396 & child % var % Interpolationshouldbemade 397 childtemp % var % list_interp => child % var% list_interp 389 398 C 390 399 Call Agrif_InterpVariable 391 400 & (TypeInterp,parent,childtemp,torestore) 401 402 child % var % list_interp => childtemp % var %list_interp 392 403 C 393 404 deallocate(childtemp % var) … … 459 470 childtemp % var % interpIndex => child % var % interpIndex 460 471 childtemp % var % Interpolationshouldbemade = 461 & child % var % Interpolationshouldbemade 472 & child % var % Interpolationshouldbemade 473 474 childtemp % var % list_interp => child % var% list_interp 462 475 C 463 476 Call Agrif_InterpVariable 464 477 & (TypeInterp,parent,childtemp,torestore) 465 478 C 479 child % var % list_interp => childtemp % var %list_interp 466 480 deallocate(childtemp % var) 467 481 C … … 591 605 C 592 606 C Local pointers 593 TYPE(AGRIF_PVARIABLE) :: tempP,tempPextend ! Temporary parent grid variable594 TYPE(AGRIF_PVARIABLE) :: tempC ! Temporary child grid variable607 TYPE(AGRIF_PVARIABLE),SAVE :: tempP,tempPextend ! Temporary parent grid variable 608 TYPE(AGRIF_PVARIABLE),SAVE :: tempC ! Temporary child grid variable 595 609 C 596 610 C Local scalars … … 605 619 INTEGER,DIMENSION(nbdim,2,2) :: parentarray 606 620 LOGICAL :: memberin,member 607 TYPE(AGRIF_PVARIABLE) :: parentvalues 621 TYPE(AGRIF_PVARIABLE),SAVE :: parentvalues 622 LOGICAL :: find_list_interp 623 INTEGER,DIMENSION(nbdim) :: indminglob2,indmaxglob2 608 624 C 609 625 #ifdef AGRIF_MPI … … 612 628 INTEGER,PARAMETER :: etiquette = 100 613 629 INTEGER :: code 614 INTEGER,DIMENSION(nbdim) :: indminglob2,indmaxglob2615 630 INTEGER,DIMENSION(nbdim,4) :: tab3 616 631 INTEGER,DIMENSION(nbdim,4,0:Agrif_Nbprocs-1) :: tab4 617 632 INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,4) :: tab4t 633 LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: memberinall 634 LOGICAL, DIMENSION(1) :: memberin1 618 635 C 619 636 #endif … … 621 638 C 622 639 C Boundaries of the current grid where interpolation is done 640 641 642 643 644 IF (Associated(child%var%list_interp)) THEN 645 Call Agrif_Find_list_interp(child%var%list_interp,pttab,petab, 646 & pttab_Child,pttab_Parent,nbdim, 647 & indmin,indmax,indminglob, 648 & indmaxglob,indminglob2,indmaxglob2,parentarray, 649 & pttruetab,cetruetab,member,memberin,find_list_interp 650 #if defined AGRIF_MPI 651 & ,tab4t,memberinall 652 #endif 653 & ) 654 ELSE 655 find_list_interp = .FALSE. 656 ENDIF 657 658 IF (.not.find_list_interp) THEN 623 659 Call Agrif_nbdim_Get_bound_dimension(child % var, 624 660 & lowerbound,upperbound,nbdim) … … 627 663 & pttab,petab, 628 664 & pttruetab,cetruetab,memberin) 665 629 666 C 630 667 C … … 640 677 641 678 642 #ifdef AGRIF_MPI 643 644 IF (memberin) THEN 645 Call Agrif_Parentbounds(TYPEinterp,nbdim,indmin,indmax, 679 #ifdef AGRIF_MPI 680 IF (memberin) THEN 681 Call Agrif_Parentbounds(TYPEinterp,nbdim,indmin,indmax, 646 682 & s_Parent_temp,s_Child_temp, 647 683 & s_Child,ds_Child, … … 651 687 & child%var%root_var%posvar, 652 688 & child % var % root_var % interptab) 653 ENDIF 654 689 ENDIF 655 690 656 691 Call Agrif_nbdim_Get_bound_dimension(parent%var, … … 671 706 & nbdim,Agrif_Procrank, 672 707 & member) 673 674 708 endif 709 675 710 Call Agrif_ParentGrid_to_ChildGrid() 676 711 #else … … 684 719 #endif 685 720 721 ELSE 722 723 #if !defined AGRIF_MPI 724 parentarray(:,1,1) = indminglob 725 parentarray(:,2,1) = indmaxglob 726 parentarray(:,1,2) = indminglob 727 parentarray(:,2,2) = indmaxglob 728 indmin = indminglob 729 indmax = indmaxglob 730 member = .TRUE. 731 s_Parent_temp = s_Parent + (indminglob - pttab_Parent)*ds_Parent 732 s_Child_temp = s_Child + (pttab - pttab_Child) * ds_Child 733 #else 734 s_Parent_temp = s_Parent + (indmin - pttab_Parent)*ds_Parent 735 s_Child_temp = s_Child + (pttruetab - pttab_Child) * ds_Child 736 #endif 737 738 ENDIF 739 686 740 687 741 688 742 IF (member) THEN 689 allocate(tempP%var)743 IF (.not.associated(tempP%var)) allocate(tempP%var) 690 744 691 745 C … … 736 790 Call Agrif_ParentGrid_to_ChildGrid() 737 791 ELSE 792 738 793 Call Agrif_nbdim_VarEQvar(tempP%var, 739 794 & parentarray(:,1,1),parentarray(:,2,1), … … 744 799 745 800 #ifdef AGRIF_MPI 801 if (.not.find_list_interp) then 746 802 tab3(:,1) = indminglob2(:) 747 803 tab3(:,2) = indmaxglob2(:) … … 753 809 & MPI_INTEGER,MPI_COMM_WORLD,code) 754 810 755 Allocate(tempPextend%var) 811 IF (.not.associated(tempPextend%var)) Allocate(tempPextend%var) 812 756 813 DO k=0,Agrif_Nbprocs-1 757 814 do j=1,4 … … 761 818 enddo 762 819 enddo 820 821 memberin1(1) = memberin 822 CALL MPI_ALLGATHER(memberin1,1,MPI_LOGICAL,memberinall, 823 & 1,MPI_LOGICAL,MPI_COMM_WORLD,code) 824 825 endif 826 763 827 Call Get_External_Data(tempP,tempPextend,tab4t(:,:,1), 764 828 & tab4t(:,:,2), 765 & tab4t(:,:,3),tab4t(:,:,4),nbdim,member,memberin) 829 & tab4t(:,:,3),tab4t(:,:,4),nbdim,member,memberin, 830 & memberinall) 766 831 #else 767 832 tempPextend%var => tempP%var 768 833 #endif 769 834 835 if (.not.find_list_interp) then 836 Call Agrif_Addto_list_interp(child%var%list_interp,pttab,petab, 837 & pttab_Child,pttab_Parent,indmin,indmax, 838 & indminglob,indmaxglob,indminglob2,indmaxglob2,parentarray, 839 & pttruetab,cetruetab,member,memberin,nbdim 840 #if defined AGRIF_MPI 841 & ,tab4t,memberinall 842 #endif 843 & ) 844 endif 845 770 846 C 771 847 C 772 848 IF (memberin) THEN 773 allocate(tempC%var)849 IF (.not.associated(tempC%var)) allocate(tempC%var) 774 850 C 775 851 … … 784 860 & child % var % root_var % interptab(1:nbdim) .EQ. 'N' 785 861 C 786 Allocate(parentvalues%var) 862 IF (.not.associated(parentvalues%var)) 863 & Allocate(parentvalues%var) 787 864 C 788 865 Call Agrif_nbdim_allocation … … 798 875 C 799 876 Call Agrif_nbdim_deallocation(parentvalues%var,nbdim) 800 Deallocate(parentvalues%var)877 C Deallocate(parentvalues%var) 801 878 C 802 879 C … … 999 1076 CASE (2) 1000 1077 do j = pttruetab(2),cetruetab(2) 1001 do i = pttruetab(1),cetruetab(1) 1002 if (restore%var%restore2D(i,j) == 0) 1078 do i = pttruetab(1),cetruetab(1) 1079 if (restore%var%restore2D(i,j) == 0) 1003 1080 & child % var % array2(i,j) = 1004 1081 & tempC % var % array2(i,j) … … 1121 1198 1122 1199 Call Agrif_nbdim_deallocation(tempPextend%var,nbdim) 1123 deallocate(tempPextend%var)1200 C deallocate(tempPextend%var) 1124 1201 1125 1202 Call Agrif_nbdim_deallocation(tempC%var,nbdim) 1126 1203 1127 Deallocate(tempC % var)1204 C Deallocate(tempC % var) 1128 1205 ELSE 1129 1206 1130 deallocate(tempPextend%var)1207 C deallocate(tempPextend%var) 1131 1208 1132 1209 ENDIF … … 1137 1214 IF (member) THEN 1138 1215 Call Agrif_nbdim_deallocation(tempP%var,nbdim) 1139 Deallocate(tempP % var)1216 C Deallocate(tempP % var) 1140 1217 endif 1141 1218 #endif … … 1169 1246 C Declarations: 1170 1247 C 1171 1172 C1173 #ifdef AGRIF_MPI1174 C1175 ccccccccccccccccccccccc#include "mpif.h"1176 C1177 #endif1178 1248 C 1179 1249 C Arguments … … 1214 1284 ELSEIF (interptab(i) .EQ. 'N') THEN 1215 1285 ELSEIF ( TYPEinterp(i) .eq. Agrif_ppm .or. 1216 & TYPEinterp(i) .eq. Agrif_eno ) THEN 1286 & TYPEinterp(i) .eq. Agrif_eno .or. 1287 & TYPEinterp(i) .eq. Agrif_weno) THEN 1217 1288 indmin(i) = indmin(i) - 2 1218 1289 indmax(i) = indmax(i) + 2 1219 ELSE IF( TYPEinterp(i) .ne. Agrif_constant ) THEN 1290 ELSE IF (( TYPEinterp(i) .ne. Agrif_constant ) 1291 & .AND.( TYPEinterp(i) .ne. Agrif_linear )) THEN 1220 1292 indmin(i) = indmin(i) - 1 1221 1293 indmax(i) = indmax(i) + 1 … … 1262 1334 REAL, DIMENSION(nbdim) :: s_child,s_parent 1263 1335 REAL, DIMENSION(nbdim) :: ds_child,ds_parent 1264 REAL, DIMENSION(indmin(nbdim):indmax(nbdim)) :: tabin 1265 REAL, DIMENSION(pttab_child(nbdim):petab_child(nbdim)) :: tabout 1336 REAL, INTENT(IN),DIMENSION(indmin(nbdim):indmax(nbdim)) :: tabin 1337 REAL, INTENT(OUT), 1338 & DIMENSION(pttab_child(nbdim):petab_child(nbdim)) :: tabout 1339 INTEGER :: coeffraf 1266 1340 C 1267 1341 C 1268 1342 C Commentaire perso : nbdim vaut toujours 1 ici. 1269 1343 C 1344 coeffraf = nint(ds_parent(nbdim)/ds_child(nbdim)) 1345 1270 1346 Call Agrif_InterpBase(TypeInterp(1), 1271 1347 & tabin(indmin(nbdim):indmax(nbdim)), … … 1274 1350 & pttab_child(nbdim),petab_child(nbdim), 1275 1351 & s_parent(nbdim),s_child(nbdim), 1276 & ds_parent(nbdim),ds_child(nbdim) )1352 & ds_parent(nbdim),ds_child(nbdim),coeffraf) 1277 1353 C 1278 1354 Return … … 1309 1385 REAL , DIMENSION(nbdim) :: s_child, s_parent 1310 1386 REAL , DIMENSION(nbdim) :: ds_child,ds_parent 1311 REAL , DIMENSION(1387 REAL ,INTENT(IN), DIMENSION( 1312 1388 & indmin(nbdim-1):indmax(nbdim-1), 1313 1389 & indmin(nbdim):indmax(nbdim) 1314 1390 & ) :: tabin 1315 REAL , DIMENSION(1391 REAL ,INTENT(OUT), DIMENSION( 1316 1392 & pttab_child(nbdim-1):petab_child(nbdim-1), 1317 1393 & pttab_child(nbdim):petab_child(nbdim) … … 1319 1395 C 1320 1396 C Local variables 1321 REAL, DIMENSION(:,:), Allocatable :: tabtemp 1397 REAL, DIMENSION(pttab_child(nbdim-1):petab_child(nbdim-1), 1398 & indmin(nbdim):indmax(nbdim)) :: tabtemp 1322 1399 INTEGER i,j 1323 C 1324 C 1325 Allocate(tabtemp(pttab_child(nbdim-1):petab_child(nbdim-1), 1326 & indmin(nbdim):indmax(nbdim))) 1400 INTEGER :: coeffraf 1401 C 1402 C 1327 1403 C 1328 1404 C … … 1341 1417 enddo 1342 1418 C 1419 coeffraf = nint(ds_parent(nbdim)/ds_child(nbdim)) 1420 1343 1421 do i=pttab_child(nbdim-1),petab_child(nbdim-1) 1344 1422 C … … 1349 1427 & pttab_child(nbdim),petab_child(nbdim), 1350 1428 & s_parent(nbdim),s_child(nbdim), 1351 & ds_parent(nbdim),ds_child(nbdim) )1429 & ds_parent(nbdim),ds_child(nbdim),coeffraf) 1352 1430 C 1353 1431 enddo 1354 C1355 Deallocate(tabtemp)1356 1432 C 1357 1433 Return … … 1384 1460 INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child 1385 1461 REAL, DIMENSION(nbdim) :: s_child,s_parent,ds_child,ds_parent 1386 REAL, DIMENSION(indmin(nbdim-2):indmax(nbdim-2),1462 REAL,INTENT(IN), DIMENSION(indmin(nbdim-2):indmax(nbdim-2), 1387 1463 & indmin(nbdim-1):indmax(nbdim-1), 1388 1464 & indmin(nbdim) :indmax(nbdim)) :: tabin 1389 REAL, DIMENSION(pttab_child(nbdim-2):petab_child(nbdim-2), 1465 REAL,INTENT(OUT), 1466 & DIMENSION(pttab_child(nbdim-2):petab_child(nbdim-2), 1390 1467 & pttab_child(nbdim-1):petab_child(nbdim-1), 1391 1468 & pttab_child(nbdim):petab_child(nbdim)) :: tabout 1392 1469 C 1393 1470 C Local variables 1394 REAL, DIMENSION(:,:,:), Allocatable :: tabtemp 1471 REAL, DIMENSION(pttab_child(nbdim-2):petab_child(nbdim-2), 1472 & pttab_child(nbdim-1):petab_child(nbdim-1), 1473 & indmin(nbdim):indmax(nbdim)) :: tabtemp 1395 1474 INTEGER i,j,k 1396 C 1397 C 1398 Allocate(tabtemp(pttab_child(nbdim-2):petab_child(nbdim-2), 1399 & pttab_child(nbdim-1):petab_child(nbdim-1), 1400 & indmin(nbdim):indmax(nbdim))) 1475 INTEGER :: coeffraf, locind_child_left, kdeb 1476 C 1401 1477 C 1402 1478 do k = indmin(nbdim),indmax(nbdim) … … 1413 1489 C 1414 1490 enddo 1491 1492 1493 Call Agrif_Compute_nbdim_interp(s_parent(nbdim),s_child(nbdim), 1494 & ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left) 1495 1496 IF (coeffraf == 1) THEN 1497 1498 kdeb = indmin(3)+locind_child_left-2 1499 do k=pttab_child(3),petab_child(3) 1500 kdeb = kdeb + 1 1501 do j = pttab_child(2),petab_child(2) 1502 do i = pttab_child(1),petab_child(1) 1503 tabout(i,j,k) = tabtemp(i,j,kdeb) 1504 enddo 1505 enddo 1506 enddo 1507 1508 ELSE 1415 1509 C 1416 1510 do j=pttab_child(nbdim-1),petab_child(nbdim-1) … … 1424 1518 & pttab_child(nbdim),petab_child(nbdim), 1425 1519 & s_parent(nbdim),s_child(nbdim), 1426 & ds_parent(nbdim),ds_child(nbdim) )1520 & ds_parent(nbdim),ds_child(nbdim),coeffraf) 1427 1521 C 1428 1522 enddo 1429 1523 C 1430 1524 enddo 1431 C 1432 Deallocate(tabtemp) 1525 ENDIF 1433 1526 C 1434 1527 Return … … 1461 1554 INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child 1462 1555 REAL, DIMENSION(nbdim) :: s_child,s_parent,ds_child,ds_parent 1463 REAL, DIMENSION(indmin(nbdim-3):indmax(nbdim-3),1556 REAL,INTENT(IN), DIMENSION(indmin(nbdim-3):indmax(nbdim-3), 1464 1557 & indmin(nbdim-2):indmax(nbdim-2), 1465 1558 & indmin(nbdim-1):indmax(nbdim-1), 1466 1559 & indmin(nbdim):indmax(nbdim)) :: tabin 1467 REAL, DIMENSION(pttab_child(nbdim-3):petab_child(nbdim-3), 1560 REAL,INTENT(OUT), 1561 & DIMENSION(pttab_child(nbdim-3):petab_child(nbdim-3), 1468 1562 & pttab_child(nbdim-2):petab_child(nbdim-2), 1469 1563 & pttab_child(nbdim-1):petab_child(nbdim-1), … … 1471 1565 C 1472 1566 C Local variables 1473 REAL, DIMENSION(:,:,:,:), Allocatable :: tabtemp 1474 INTEGER i,j,k,l 1475 C 1476 C 1477 Allocate(tabtemp(pttab_child(nbdim-3):petab_child(nbdim-3), 1567 REAL, DIMENSION(pttab_child(nbdim-3):petab_child(nbdim-3), 1478 1568 & pttab_child(nbdim-2):petab_child(nbdim-2), 1479 1569 & pttab_child(nbdim-1):petab_child(nbdim-1), 1480 & indmin(nbdim):indmax(nbdim))) 1570 & indmin(nbdim):indmax(nbdim)) :: tabtemp 1571 INTEGER i,j,k,l 1572 INTEGER :: coeffraf 1573 C 1481 1574 C 1482 1575 do l = indmin(nbdim),indmax(nbdim) … … 1496 1589 enddo 1497 1590 C 1591 coeffraf = nint(ds_parent(nbdim)/ds_child(nbdim)) 1592 1498 1593 do k = pttab_child(nbdim-1),petab_child(nbdim-1) 1499 1594 C … … 1508 1603 & pttab_child(nbdim),petab_child(nbdim), 1509 1604 & s_parent(nbdim),s_child(nbdim), 1510 & ds_parent(nbdim),ds_child(nbdim) )1605 & ds_parent(nbdim),ds_child(nbdim),coeffraf) 1511 1606 C 1512 1607 enddo … … 1515 1610 C 1516 1611 enddo 1517 C1518 Deallocate(tabtemp)1519 1612 C 1520 1613 Return … … 1547 1640 INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child 1548 1641 REAL, DIMENSION(nbdim) :: s_child,s_parent,ds_child,ds_parent 1549 REAL, DIMENSION(indmin(nbdim-4):indmax(nbdim-4),1642 REAL,INTENT(IN), DIMENSION(indmin(nbdim-4):indmax(nbdim-4), 1550 1643 & indmin(nbdim-3):indmax(nbdim-3), 1551 1644 & indmin(nbdim-2):indmax(nbdim-2), 1552 1645 & indmin(nbdim-1):indmax(nbdim-1), 1553 1646 & indmin(nbdim):indmax(nbdim)) :: tabin 1554 REAL, DIMENSION(pttab_child(nbdim-4):petab_child(nbdim-4), 1647 REAL,INTENT(OUT), 1648 & DIMENSION(pttab_child(nbdim-4):petab_child(nbdim-4), 1555 1649 & pttab_child(nbdim-3):petab_child(nbdim-3), 1556 1650 & pttab_child(nbdim-2):petab_child(nbdim-2), … … 1559 1653 C 1560 1654 C Local variables 1561 REAL, DIMENSION(:,:,:,:,:), Allocatable :: tabtemp 1562 INTEGER i,j,k,l,m 1563 C 1564 C 1565 Allocate(tabtemp(pttab_child(nbdim-4):petab_child(nbdim-4), 1655 REAL, DIMENSION(pttab_child(nbdim-4):petab_child(nbdim-4), 1566 1656 & pttab_child(nbdim-3):petab_child(nbdim-3), 1567 1657 & pttab_child(nbdim-2):petab_child(nbdim-2), 1568 1658 & pttab_child(nbdim-1):petab_child(nbdim-1), 1569 & indmin(nbdim):indmax(nbdim))) 1659 & indmin(nbdim):indmax(nbdim)) :: tabtemp 1660 INTEGER i,j,k,l,m 1661 INTEGER :: coeffraf 1662 C 1570 1663 C 1571 1664 do m = indmin(nbdim),indmax(nbdim) … … 1586 1679 C 1587 1680 enddo 1681 1682 coeffraf = nint(ds_parent(nbdim)/ds_child(nbdim)) 1588 1683 C 1589 1684 do l = pttab_child(nbdim-1),petab_child(nbdim-1) … … 1602 1697 & pttab_child(nbdim),petab_child(nbdim), 1603 1698 & s_parent(nbdim),s_child(nbdim), 1604 & ds_parent(nbdim),ds_child(nbdim) )1699 & ds_parent(nbdim),ds_child(nbdim),coeffraf) 1605 1700 C 1606 1701 enddo … … 1611 1706 C 1612 1707 enddo 1613 C 1614 Deallocate(tabtemp) 1708 C 1615 1709 C 1616 1710 Return … … 1643 1737 INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child 1644 1738 REAL, DIMENSION(nbdim) :: s_child,s_parent,ds_child,ds_parent 1645 REAL, DIMENSION(indmin(nbdim-5):indmax(nbdim-5),1739 REAL,INTENT(IN), DIMENSION(indmin(nbdim-5):indmax(nbdim-5), 1646 1740 & indmin(nbdim-4):indmax(nbdim-4), 1647 1741 & indmin(nbdim-3):indmax(nbdim-3), … … 1649 1743 & indmin(nbdim-1):indmax(nbdim-1), 1650 1744 & indmin(nbdim):indmax(nbdim)) :: tabin 1651 REAL, DIMENSION(pttab_child(nbdim-5):petab_child(nbdim-5), 1745 REAL,INTENT(OUT), 1746 & DIMENSION(pttab_child(nbdim-5):petab_child(nbdim-5), 1652 1747 & pttab_child(nbdim-4):petab_child(nbdim-4), 1653 1748 & pttab_child(nbdim-3):petab_child(nbdim-3), … … 1657 1752 C 1658 1753 C Local variables 1659 REAL, DIMENSION(:,:,:,:,:,:), Allocatable :: tabtemp 1660 INTEGER i,j,k,l,m,n 1661 C 1662 C 1663 Allocate(tabtemp(pttab_child(nbdim-5):petab_child(nbdim-5), 1754 REAL, DIMENSION(pttab_child(nbdim-5):petab_child(nbdim-5), 1664 1755 & pttab_child(nbdim-4):petab_child(nbdim-4), 1665 1756 & pttab_child(nbdim-3):petab_child(nbdim-3), 1666 1757 & pttab_child(nbdim-2):petab_child(nbdim-2), 1667 1758 & pttab_child(nbdim-1):petab_child(nbdim-1), 1668 & indmin(nbdim):indmax(nbdim))) 1759 & indmin(nbdim):indmax(nbdim)) :: tabtemp 1760 INTEGER i,j,k,l,m,n 1761 INTEGER :: coeffraf 1762 C 1763 C 1669 1764 C 1670 1765 do n = indmin(nbdim),indmax(nbdim) … … 1687 1782 C 1688 1783 enddo 1784 1785 coeffraf = nint(ds_parent(nbdim)/ds_child(nbdim)) 1689 1786 C 1690 1787 do m = pttab_child(nbdim-1),petab_child(nbdim-1) … … 1704 1801 & pttab_child(nbdim),petab_child(nbdim), 1705 1802 & s_parent(nbdim),s_child(nbdim), 1706 & ds_parent(nbdim),ds_child(nbdim) )1803 & ds_parent(nbdim),ds_child(nbdim),coeffraf) 1707 1804 C 1708 1805 enddo … … 1715 1812 enddo 1716 1813 C 1717 Deallocate(tabtemp)1718 1814 C 1719 1815 Return … … 1731 1827 & parenttab,childtab, 1732 1828 & indmin,indmax,pttab_child,petab_child, 1733 & s_parent,s_child,ds_parent,ds_child) 1829 & s_parent,s_child,ds_parent,ds_child, 1830 & coeffraf) 1734 1831 C 1735 1832 CCC Description: … … 1744 1841 INTEGER :: indmin,indmax 1745 1842 INTEGER :: pttab_child,petab_child 1746 REAL, DIMENSION(indmin:indmax) :: parenttab1747 REAL, DIMENSION(pttab_child:petab_child) :: childtab1843 REAL,INTENT(IN),DIMENSION(indmin:indmax) :: parenttab 1844 REAL,INTENT(OUT),DIMENSION(pttab_child:petab_child) :: childtab 1748 1845 REAL :: s_parent,s_child,ds_parent,ds_child 1846 INTEGER :: coeffraf 1749 1847 C 1750 1848 C … … 1774 1872 & indmax-indmin+1,petab_child-pttab_child+1, 1775 1873 & s_parent,s_child,ds_parent,ds_child) 1776 C 1874 C 1875 elseif (TYPEinterp .EQ. AGRIF_WENO) then 1876 C 1877 C Eno interpolation 1878 Call weno1D 1879 & (parenttab,childtab, 1880 & indmax-indmin+1,petab_child-pttab_child+1, 1881 & s_parent,s_child,ds_parent,ds_child) 1882 C 1777 1883 Else if (TYPEinterp .EQ. AGRIF_LINEARCONSERV) then 1778 1884 C … … 1812 1918 C 1813 1919 1814 1815 C 1920 Subroutine Agrif_Compute_nbdim_interp(s_parent,s_child, 1921 & ds_parent,ds_child,coeffraf,locind_child_left) 1922 real :: s_parent,s_child,ds_parent,ds_child 1923 integer :: coeffraf,locind_child_left 1924 1925 coeffraf = nint(ds_parent/ds_child) 1926 locind_child_left = 1 + agrif_int((s_child-s_parent)/ds_parent) 1927 End Subroutine Agrif_Compute_nbdim_interp 1928 C 1929 1930 Subroutine Agrif_Find_list_interp(list_interp,pttab,petab, 1931 & pttab_Child,pttab_Parent,nbdim, 1932 & indmin,indmax,indminglob, 1933 & indmaxglob,indminglob2,indmaxglob2,parentarray, 1934 & pttruetab,cetruetab,member,memberin, 1935 & find_list_interp 1936 #if defined AGRIF_MPI 1937 & ,tab4t,memberinall 1938 #endif 1939 & ) 1940 TYPE(Agrif_List_Interp_Loc), Pointer :: list_interp 1941 INTEGER :: nbdim 1942 INTEGER,DIMENSION(nbdim) :: pttab,petab,pttab_Child,pttab_Parent 1943 LOGICAL :: find_list_interp 1944 Type(Agrif_List_Interp_loc), Pointer :: parcours 1945 INTEGER,DIMENSION(nbdim) :: indmin,indmax 1946 INTEGER,DIMENSION(nbdim) :: indminglob,indmaxglob 1947 INTEGER,DIMENSION(nbdim) :: pttruetab,cetruetab 1948 INTEGER,DIMENSION(nbdim) :: indminglob2,indmaxglob2 1949 INTEGER,DIMENSION(nbdim,2,2) :: parentarray 1950 LOGICAL :: member, memberin 1951 INTEGER :: i 1952 #ifdef AGRIF_MPI 1953 C 1954 INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,4) :: tab4t 1955 LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: memberinall 1956 #endif 1957 1958 find_list_interp = .FALSE. 1959 1960 parcours => list_interp 1961 Find_loop : Do While (associated(parcours)) 1962 Do i=1,nbdim 1963 IF ((pttab(i) /= parcours%interp_loc%pttab(i)).OR. 1964 & (petab(i) /= parcours%interp_loc%petab(i)).OR. 1965 & (pttab_child(i) /= parcours%interp_loc%pttab_child(i)).OR. 1966 & (pttab_parent(i) /= parcours%interp_loc%pttab_parent(i))) 1967 & THEN 1968 parcours=>parcours%suiv 1969 Cycle Find_loop 1970 ENDIF 1971 EndDo 1972 C print *,'ok trouve' 1973 indmin = parcours%interp_loc%indmin(1:nbdim) 1974 indmax = parcours%interp_loc%indmax(1:nbdim) 1975 1976 pttruetab = parcours%interp_loc%pttruetab(1:nbdim) 1977 cetruetab = parcours%interp_loc%cetruetab(1:nbdim) 1978 1979 #if !defined AGRIF_MPI 1980 indminglob = parcours%interp_loc%indminglob(1:nbdim) 1981 indmaxglob = parcours%interp_loc%indmaxglob(1:nbdim) 1982 #else 1983 indminglob2 = parcours%interp_loc%indminglob2(1:nbdim) 1984 indmaxglob2 = parcours%interp_loc%indmaxglob2(1:nbdim) 1985 parentarray = parcours%interp_loc%parentarray(1:nbdim,:,:) 1986 member = parcours%interp_loc%member 1987 tab4t = parcours%interp_loc%tab4t(1:nbdim,0:Agrif_Nbprocs-1,1:4) 1988 memberinall = parcours%interp_loc%memberinall(0:Agrif_Nbprocs-1) 1989 #endif 1990 memberin = parcours%interp_loc%memberin 1991 find_list_interp = .TRUE. 1992 Exit Find_loop 1993 End Do Find_loop 1994 1995 End Subroutine Agrif_Find_list_interp 1996 1997 Subroutine Agrif_AddTo_list_interp(list_interp,pttab,petab, 1998 & pttab_Child,pttab_Parent,indmin,indmax, 1999 & indminglob,indmaxglob, 2000 & indminglob2,indmaxglob2, 2001 & parentarray,pttruetab,cetruetab, 2002 & member,memberin,nbdim 2003 #if defined AGRIF_MPI 2004 & ,tab4t,memberinall 2005 #endif 2006 & ) 2007 2008 TYPE(Agrif_List_Interp_Loc), Pointer :: list_interp 2009 INTEGER :: nbdim 2010 INTEGER,DIMENSION(nbdim) :: pttab,petab,pttab_Child,pttab_Parent 2011 INTEGER,DIMENSION(nbdim) :: indmin,indmax 2012 INTEGER,DIMENSION(nbdim) :: indminglob,indmaxglob 2013 INTEGER,DIMENSION(nbdim) :: indminglob2,indmaxglob2 2014 INTEGER,DIMENSION(nbdim) :: pttruetab,cetruetab 2015 INTEGER,DIMENSION(nbdim,2,2) :: parentarray 2016 LOGICAL :: member, memberin 2017 #ifdef AGRIF_MPI 2018 C 2019 INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,4) :: tab4t 2020 LOGICAL,DIMENSION(0:Agrif_Nbprocs-1) :: memberinall 2021 #endif 2022 Type(Agrif_List_Interp_loc), Pointer :: parcours 2023 2024 Allocate(parcours) 2025 Allocate(parcours%interp_loc) 2026 2027 parcours%interp_loc%pttab(1:nbdim) = pttab(1:nbdim) 2028 parcours%interp_loc%petab(1:nbdim) = petab(1:nbdim) 2029 parcours%interp_loc%pttab_child(1:nbdim) = pttab_child(1:nbdim) 2030 parcours%interp_loc%pttab_parent(1:nbdim) = pttab_parent(1:nbdim) 2031 2032 2033 parcours%interp_loc%indmin(1:nbdim) = indmin(1:nbdim) 2034 parcours%interp_loc%indmax(1:nbdim) = indmax(1:nbdim) 2035 2036 parcours%interp_loc%memberin = memberin 2037 #if !defined AGRIF_MPI 2038 parcours%interp_loc%indminglob(1:nbdim) = indminglob(1:nbdim) 2039 parcours%interp_loc%indmaxglob(1:nbdim) = indmaxglob(1:nbdim) 2040 #else 2041 parcours%interp_loc%indminglob2(1:nbdim) = indminglob2(1:nbdim) 2042 parcours%interp_loc%indmaxglob2(1:nbdim) = indmaxglob2(1:nbdim) 2043 parcours%interp_loc%parentarray(1:nbdim,:,:) 2044 & = parentarray(1:nbdim,:,:) 2045 parcours%interp_loc%member = member 2046 Allocate(parcours%interp_loc%tab4t(nbdim,0:Agrif_Nbprocs-1,4)) 2047 Allocate(parcours%interp_loc%memberinall(0:Agrif_Nbprocs-1)) 2048 parcours%interp_loc%tab4t=tab4t 2049 parcours%interp_loc%memberinall=memberinall 2050 #endif 2051 2052 parcours%interp_loc%pttruetab(1:nbdim) = pttruetab(1:nbdim) 2053 parcours%interp_loc%cetruetab(1:nbdim) = cetruetab(1:nbdim) 2054 2055 parcours%suiv => list_interp 2056 2057 list_interp => parcours 2058 End Subroutine Agrif_Addto_list_interp 2059 1816 2060 End Module Agrif_Interpolation -
trunk/AGRIF/AGRIF_FILES/modinterpbasic.F
r447 r662 36 36 IMPLICIT NONE 37 37 C 38 Real,Dimension(Agrif_MaxRaff) :: tabdiff2, tabdiff3 39 Real,Dimension(:),Allocatable::tabtest4 40 38 41 CONTAINS 39 42 C Define procedures contained in this module 40 C 41 C 43 C 42 44 C ************************************************************************** 43 45 CCC Subroutine Linear1d … … 59 61 C Arguments 60 62 INTEGER :: np,nc 61 REAL, DIMENSION(np) :: x62 REAL, DIMENSION(nc) :: y63 REAL,INTENT(IN), DIMENSION(np) :: x 64 REAL,INTENT(OUT), DIMENSION(nc) :: y 63 65 REAL :: s_parent,s_child,ds_parent,ds_child 64 66 C 65 67 C Local scalars 66 68 INTEGER :: i,coeffraf,locind_parent_left 67 REAL :: ypos,globind_parent_left 69 REAL :: ypos,globind_parent_left,globind_parent_right 70 REAL :: invds, invds2 71 REAL :: ypos2,diff 68 72 C 69 73 C … … 81 85 endif 82 86 C 83 ypos = s_child 84 C 85 do i = 1,nc-1 86 C 87 locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent) 88 C 87 ypos = s_child 88 89 locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent) 90 89 91 globind_parent_left = s_parent 90 92 & + (locind_parent_left - 1)*ds_parent 91 C 92 y(i) = ((globind_parent_left + ds_parent - ypos) 93 & *x(locind_parent_left) 94 & + (ypos - globind_parent_left) 95 & *x(locind_parent_left+1)) 96 & / ds_parent 97 C 98 ypos = ypos + ds_child 93 94 globind_parent_right = globind_parent_left + ds_parent 95 96 C 97 invds = 1./ds_parent 98 invds2 = ds_child/ds_parent 99 100 ypos2 = ypos*invds 101 globind_parent_right=globind_parent_right*invds 102 103 do i = 1,nc-1 104 C 105 if (ypos2 > globind_parent_right) then 106 locind_parent_left = locind_parent_left + 1. 107 globind_parent_right = globind_parent_right + 1. 108 endif 109 110 diff=(globind_parent_right - ypos2) 111 112 y(i) = (diff*x(locind_parent_left) 113 & + (1.-diff)*x(locind_parent_left+1)) 114 C 115 ypos2 = ypos2 + invds2 99 116 C 100 117 enddo 101 118 C 119 ypos = s_child + (nc-1)*ds_child 102 120 locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent) 103 121 C … … 114 132 & *x(locind_parent_left) 115 133 & + (ypos - globind_parent_left) 116 & *x(locind_parent_left+1)) 117 & / ds_parent 134 & *x(locind_parent_left+1))*invds 118 135 C 119 136 endif … … 123 140 C 124 141 End Subroutine Linear1d 142 125 143 C 126 144 C … … 145 163 C Arguments 146 164 INTEGER :: np,nc 147 REAL, DIMENSION(np) :: x148 REAL, DIMENSION(nc) :: y165 REAL,INTENT(IN), DIMENSION(np) :: x 166 REAL,INTENT(OUT), DIMENSION(nc) :: y 149 167 REAL :: s_parent,s_child,ds_parent,ds_child 150 168 C … … 153 171 REAL :: ypos,globind_parent_left 154 172 REAL :: X1,X2,X3 173 real :: deltax,invdsparent 174 real t1,t2,t3,t4,t5,t6,t7,t8 155 175 C 156 176 C … … 175 195 C 176 196 endif 197 198 invdsparent=1./ds_parent 177 199 C 178 200 ypos = s_child … … 182 204 locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent) 183 205 C 206 184 207 globind_parent_left = s_parent 185 208 & + (locind_parent_left - 1)*ds_parent 186 C 187 if (locind_parent_left+2 <= np) then 188 C 189 X1 = (x(locind_parent_left+1)-x(locind_parent_left)) 190 & /ds_parent 191 C 192 X2 = (x(locind_parent_left+2)-x(locind_parent_left+1)) 193 & /ds_parent 194 C 195 X3 = (X2 - X1)/(2.*ds_parent) 196 C 197 y(i) = x(locind_parent_left) + 198 & (ypos - globind_parent_left)*X1 + 199 & (ypos - globind_parent_left)* 200 & (ypos - globind_parent_left - ds_parent)*X3 201 C 202 elseif (locind_parent_left+1 <= np) then 203 C 204 X1 = (x(locind_parent_left)-x(locind_parent_left-1)) 205 & /ds_parent 206 C 207 X2 = (x(locind_parent_left+1)-x(locind_parent_left)) 208 & /ds_parent 209 C 210 X3 = (X2 - X1)/(2.*ds_parent) 211 C 212 y(i) = x(locind_parent_left-1) + 213 & (ypos - globind_parent_left - ds_parent)*X1 + 214 & (ypos - globind_parent_left - ds_parent)* 215 & (ypos - globind_parent_left)*X3 216 C 217 else 218 C 219 X1 = (x(locind_parent_left-1)-x(locind_parent_left-2)) 220 & /ds_parent 221 C 222 X2 = (x(locind_parent_left)-x(locind_parent_left-1)) 223 & /ds_parent 224 C 225 X3 = (X2 - X1)/(2.*ds_parent) 226 C 227 y(i) = x(locind_parent_left-2) + 228 & (ypos - globind_parent_left - 2.*ds_parent)*X1 + 229 & (ypos - globind_parent_left - 2.*ds_parent)* 230 & (ypos - globind_parent_left - ds_parent)*X3 231 C 232 endif 233 C 234 ypos = ypos + ds_child 209 210 deltax = invdsparent*(ypos-globind_parent_left) 211 ypos = ypos + ds_child 212 if (abs(deltax).LE.0.0001) then 213 y(i)=x(locind_parent_left) 214 215 cycle 216 endif 217 C 218 C 219 t2 = deltax - 2. 220 t3 = deltax - 1. 221 t4 = deltax + 1. 222 223 t5 = -(1./6.)*deltax*t2*t3 224 t6 = 0.5*t2*t3*t4 225 t7 = -0.5*deltax*t2*t4 226 t8 = (1./6.)*deltax*t3*t4 227 228 y(i)=t5*x(locind_parent_left-1)+t6*x(locind_parent_left) 229 & +t7*x(locind_parent_left+1)+t8*x(locind_parent_left+2) 230 C 235 231 C 236 232 enddo … … 261 257 C Arguments 262 258 INTEGER :: np,nc 263 REAL, DIMENSION(np) :: x264 REAL, DIMENSION(nc) :: y259 REAL,INTENT(IN), DIMENSION(np) :: x 260 REAL,INTENT(OUT), DIMENSION(nc) :: y 265 261 REAL :: s_parent,s_child,ds_parent,ds_child 266 262 C … … 551 547 C Arguments 552 548 Integer :: np,nc 553 Real, Dimension(np) :: x554 Real, Dimension(nc) :: y555 Real, Dimension(:),Allocatable :: ytemp549 Real, INTENT(IN),Dimension(np) :: x 550 Real, INTENT(OUT),Dimension(nc) :: y 551 C Real, Dimension(:),Allocatable :: ytemp 556 552 Real :: s_parent,s_child,ds_parent,ds_child 557 553 C … … 561 557 Real :: ypos 562 558 integer :: i1,jj 563 Real :: xpmin, cavg,a,b559 Real :: xpmin,a 564 560 C 565 561 Real :: xrmin,xrmax,am3,s2,s1 566 Real, Dimension(np) :: dela,xr,xl,delta,a6,slope,slope2567 Real, Dimension(:),Allocatable :: diff,diff2,diff3562 Real, Dimension(np) :: xl,delta,a6,slope 563 C Real, Dimension(:),Allocatable :: diff,diff2,diff3 568 564 INTEGER :: diffmod 565 REAL :: invcoeffraf 569 566 C 570 567 coeffraf = nint(ds_parent/ds_child) … … 575 572 return 576 573 End If 577 C 578 Allocate(ytemp(-2*coeffraf:nc+2*coeffraf)) 574 invcoeffraf = ds_child/ds_parent 575 C 576 577 IF( .NOT. allocated(tabtest4) ) THEN 578 Allocate(tabtest4(-2*coeffraf:nc+2*coeffraf)) 579 ELSE 580 IF (size(tabtest4) .LT. nc+4*coeffraf+1)THEN 581 deallocate( tabtest4 ) 582 Allocate(tabtest4(-2*coeffraf:nc+2*coeffraf)) 583 ENDIF 584 ENDIF 579 585 ypos = s_child 580 586 C … … 587 593 i1 = 1+agrif_int((xpmin-s_child)/ds_child) 588 594 C 589 Allocate( diff(coeffraf),diff2(coeffraf),diff3(coeffraf) ) 590 C 591 diff(:) = ds_child/ds_parent 592 C 595 C 596 593 597 Do i=1,coeffraf 594 a = real(i-1)*ds_child/ds_parent 595 b = real(i)*ds_child/ds_parent 596 diff2(i) = 0.5*(b*b - a*a) 597 diff3(i) = (1./3.)*(b*b*b - a*a*a) 598 End do 598 tabdiff2(i)=(real(i)-0.5)*invcoeffraf 599 EndDo 600 601 a = invcoeffraf**2 602 tabdiff3(1) = (1./3.)*a 603 a=2.*a 604 Do i=2,coeffraf 605 tabdiff3(i) = tabdiff3(i-1)+(real(i)-1)*a 606 EndDo 599 607 C 600 608 if( locind_parent_last+2 <= np ) then … … 612 620 endif 613 621 C 622 C 614 623 Do i = nmin,nmax 615 624 slope(i) = x(i) - x(i-1) 616 slope2(i) = 2.*abs(slope(i))617 625 Enddo 618 C 619 Do i = nmin,nmax-1 620 dela(i) = 0.5 * ( slope(i) + slope(i+1) ) 621 C Van Leer slope limiter 622 dela(i) = min( abs(dela(i)),slope2(i), 623 & slope2(i+1) )*sign(1.,dela(i)) 624 IF( slope(i)*slope(i+1) <= 0. ) dela(i) = 0. 626 627 Do i = nmin+1,nmax-1 628 xl(i)= 0.5*(x(i-1)+x(i)) 629 & -0.08333333333333*(slope(i+1)-slope(i-1)) 625 630 Enddo 626 631 C 627 Do i = nmin,nmax-2628 xr(i) = x(i) + (1./2.)*slope(i+1) + (-1./6.)*dela(i+1)629 & + ( 1./6. )*dela(i)630 Enddo631 C632 Do i = nmin,nmax-2633 xrmin = min(x(i),x(i+1))634 xrmax = max(x(i),x(i+1))635 xr(i) = min(xr(i),xrmax)636 xr(i) = max(xr(i),xrmin)637 xl(i+1) = xr(i)638 Enddo639 632 C apply parabolic monotonicity 640 633 Do i = locind_parent_left,locind_parent_last 641 If( ( (xr(i)-x(i))* (x(i)-xl(i)) ) .le. 0. ) then 642 xl(i) = x(i) 643 xr(i) = x(i) 644 Endif 645 delta(i) = xr(i) - xl(i) 646 am3 = 3. * x(i) 647 s1 = am3 - 2. * xr(i) 648 s2 = am3 - 2. * xl(i) 649 IF( delta(i) * (xl(i) - s1) .le. 0. ) xl(i) = s1 650 IF( delta(i) * (s2 - xr(i)) .le. 0. ) xr(i) = s2 651 delta(i) = xr(i) - xl(i) 652 a6(i) = 6.*x(i)-3.*(xl(i) +xr(i)) 634 delta(i) = xl(i+1) - xl(i) 635 a6(i) = 6.*x(i)-3.*(xl(i) +xl(i+1)) 653 636 C 654 637 End do 655 638 C 656 639 diffmod = 0 657 IF (mod(coeffraf,2) == 0) diffmod = 1640 IF (mod(coeffraf,2) == 0) diffmod = 1 658 641 C 659 642 ipos = i1 … … 661 644 Do iparent = locind_parent_left,locind_parent_last 662 645 pos=1 663 cavg = 0.664 646 Do jj = ipos - coeffraf/2+diffmod,ipos + coeffraf/2 665 647 C 666 ytemp(jj) = (diff(pos)*xl(iparent) 667 & + diff2(pos) 668 & * (delta(iparent)+a6(iparent)) 669 & - diff3(pos)*a6(iparent))*coeffraf 670 671 cavg = cavg + ytemp(jj) 648 tabtest4(jj) = xl(iparent) 649 & + tabdiff2(pos) * (delta(iparent)+a6(iparent)) 650 & - tabdiff3(pos) * a6(iparent) 672 651 pos = pos+1 673 652 End do … … 677 656 C 678 657 C 658 y(1:nc)=tabtest4(1:nc) 659 660 Return 661 End Subroutine ppm1d 662 663 C ************************************************************************** 664 CCC Subroutine weno1d 665 C ************************************************************************** 666 C 667 Subroutine weno1dnew(x,y,np,nc, 668 & s_parent,s_child,ds_parent,ds_child) 669 C 670 CCC Description: 671 CCC Subroutine to do a 1D interpolation and apply monotonicity constraints 672 CCC using piecewise parabolic method 673 CCC on a child grid (vector y) from its parent grid (vector x). 674 CC Method: 675 C 676 C Declarations: 677 C 678 Implicit none 679 C 680 C Arguments 681 Integer :: np,nc 682 Real, Dimension(np) :: x 683 Real, Dimension(nc) :: y 684 Real, Dimension(:),Allocatable :: ytemp 685 Real :: s_parent,s_child,ds_parent,ds_child 686 C 687 C Local scalars 688 Integer :: i,coeffraf,locind_parent_left,locind_parent_last 689 Integer :: iparent,ipos,pos,nmin,nmax 690 Real :: ypos 691 integer :: i1,jj 692 Real :: xpmin,cavg,a,b 693 C 694 Real :: xrmin,xrmax,am3,s2,s1 695 Real, Dimension(np) :: xr,xl,delta,a6,slope,slope2,smooth 696 Real, Dimension(:),Allocatable :: diff,diff2,diff3 697 INTEGER :: diffmod 698 REAL :: invcoeffraf 699 integer :: s,l,k 700 integer :: etan, etap 701 real :: delta0, delta1, delta2 702 real :: epsilon 703 parameter (epsilon = 1.D-8) 704 real, dimension(:,:), allocatable :: ak, ck 705 C 706 coeffraf = nint(ds_parent/ds_child) 707 C 708 If (coeffraf == 1) Then 709 locind_parent_left = 1 + nint((s_child - s_parent)/ds_parent) 710 y(1:nc) = x(locind_parent_left:locind_parent_left+nc-1) 711 return 712 End If 713 invcoeffraf = ds_child/ds_parent 714 Allocate(ak(0:1,coeffraf)) 715 Allocate(ck(0:1,coeffraf)) 716 717 C 718 Allocate(ytemp(-2*coeffraf:nc+2*coeffraf)) 719 ypos = s_child 720 C 721 locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent) 722 locind_parent_last = 1 + 723 & agrif_ceiling((ypos +(nc - 1) 724 & *ds_child - s_parent)/ds_parent) 725 C 726 xpmin = s_parent + (locind_parent_left-1)*ds_parent 727 i1 = 1+agrif_int((xpmin-s_child)/ds_child) 728 C 729 Allocate( diff(coeffraf),diff2(coeffraf),diff3(coeffraf) ) 730 C 731 diff(1)=0.5*invcoeffraf 732 do i=2,coeffraf 733 diff(i) = diff(i-1)+invcoeffraf 734 enddo 735 736 ak = 0. 737 ck = 0. 738 739 do i=1,coeffraf 740 do k=0,1 741 do s=0,2 742 do l=0,2 743 if (l /= s) then 744 ak(k,i) = ak(k,i)+(diff(i)-(k-l+1.)) 745 endif 746 enddo 747 enddo 748 enddo 749 750 etap = 0 751 etan = 0 752 do k=0,1 753 if (ak(k,i) > 0) then 754 etap = etap+1 755 else if (ak(k,i) < 0) then 756 etan = etan + 1 757 endif 758 enddo 759 760 do k=0,1 761 if (ak(k,i) == 0) then 762 Ck(k,i) = 1. 763 else if (ak(k,i) > 0) then 764 Ck(k,i) = 1./(etap * ak(k,i)) 765 else 766 Ck(k,i) = -1./(etan * ak(k,i)) 767 endif 768 enddo 769 enddo 770 771 C 772 a = 0. 773 b = invcoeffraf 774 Do i=1,coeffraf 775 diff2(i) = 0.5*(b*b - a*a) 776 diff3(i) = (1./3.)*(b*b*b - a*a*a) 777 a = a + invcoeffraf 778 b = b + invcoeffraf 779 End do 780 C 781 if( locind_parent_last+2 <= np ) then 782 nmax = locind_parent_last+2 783 elseif( locind_parent_last+1 <= np ) then 784 nmax = locind_parent_last+1 785 else 786 nmax = locind_parent_last 787 endif 788 C 789 if(locind_parent_left-2 >= 1) then 790 nmin = locind_parent_left-2 791 elseif(locind_parent_left-1 >= 1) then 792 nmin = locind_parent_left-1 793 else 794 nmin = locind_parent_left 795 endif 796 C 797 Do i = nmin+1,nmax 798 slope(i) = (x(i) - x(i-1)) 799 Enddo 800 DO i=nmin+2,nmax 801 smooth(i) = 0.5*(slope(i)**2+slope(i-1)**2) 802 & +(slope(i)-slope(i-1))**2 803 enddo 804 C 805 diffmod = 0 806 IF (mod(coeffraf,2) == 0) diffmod = 1 807 C 808 ipos = i1 809 C 810 Do iparent = locind_parent_left,locind_parent_last 811 pos=1 812 813 delta0=1./(epsilon+smooth(iparent ))**3 814 delta1=1./(epsilon+smooth(iparent+1))**3 815 delta2=1./(epsilon+smooth(iparent+2))**3 816 817 Do jj = ipos - coeffraf/2+diffmod,ipos + coeffraf/2 818 C 819 pos = pos+1 820 End do 821 ipos = ipos + coeffraf 822 C 823 End do 824 C 825 C 679 826 y(1:nc)=ytemp(1:nc) 680 827 deallocate(ytemp) 681 828 deallocate(diff, diff2, diff3) 829 830 deallocate(ak,ck) 831 682 832 Return 683 End Subroutine ppm1d 833 End Subroutine weno1dnew 834 835 C ************************************************************************** 836 CCC Subroutine weno1d 837 C ************************************************************************** 838 C 839 Subroutine weno1d(x,y,np,nc, 840 & s_parent,s_child,ds_parent,ds_child) 841 C 842 CCC Description: 843 CCC Subroutine to do a 1D interpolation and apply monotonicity constraints 844 CCC using piecewise parabolic method 845 CCC on a child grid (vector y) from its parent grid (vector x). 846 CC Method: 847 C 848 C Declarations: 849 C 850 Implicit none 851 C 852 C Arguments 853 Integer :: np,nc 854 Real, Dimension(np) :: x 855 Real, Dimension(nc) :: y 856 Real, Dimension(:),Allocatable :: ytemp 857 Real :: s_parent,s_child,ds_parent,ds_child 858 C 859 C Local scalars 860 Integer :: i,coeffraf,locind_parent_left,locind_parent_last 861 Integer :: iparent,ipos,pos,nmin,nmax 862 Real :: ypos 863 integer :: i1,jj 864 Real :: xpmin,cavg,a,b 865 C 866 Real :: xrmin,xrmax,am3,s2,s1 867 Real, Dimension(np) :: xr,xl,delta,a6,slope,slope2 868 Real, Dimension(:),Allocatable :: diff,diff2,diff3 869 INTEGER :: diffmod 870 REAL :: invcoeffraf 871 integer :: s,l,k 872 integer :: etan, etap 873 real :: delta0, delta1,sumdelta 874 real :: epsilon 875 parameter (epsilon = 1.D-8) 876 C 877 coeffraf = nint(ds_parent/ds_child) 878 C 879 If (coeffraf == 1) Then 880 locind_parent_left = 1 + nint((s_child - s_parent)/ds_parent) 881 y(1:nc) = x(locind_parent_left:locind_parent_left+nc-1) 882 return 883 End If 884 invcoeffraf = ds_child/ds_parent 885 886 C 887 Allocate(ytemp(-2*coeffraf:nc+2*coeffraf)) 888 ypos = s_child 889 C 890 locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent) 891 locind_parent_last = 1 + 892 & agrif_ceiling((ypos +(nc - 1) 893 & *ds_child - s_parent)/ds_parent) 894 C 895 xpmin = s_parent + (locind_parent_left-1)*ds_parent 896 i1 = 1+agrif_int((xpmin-s_child)/ds_child) 897 C 898 Allocate( diff(coeffraf)) 899 C 900 diff(1)=0.5*invcoeffraf 901 do i=2,coeffraf 902 diff(i) = diff(i-1)+invcoeffraf 903 enddo 904 C 905 if( locind_parent_last+2 <= np ) then 906 nmax = locind_parent_last+2 907 else if( locind_parent_last+1 <= np ) then 908 nmax = locind_parent_last+1 909 else 910 nmax = locind_parent_last 911 endif 912 C 913 if(locind_parent_left-1 >= 1) then 914 nmin = locind_parent_left-1 915 else 916 nmin = locind_parent_left 917 endif 918 C 919 Do i = nmin+1,nmax 920 slope(i) = (x(i) - x(i-1)) 921 Enddo 922 C 923 diffmod = 0 924 IF (mod(coeffraf,2) == 0) diffmod = 1 925 C 926 ipos = i1 927 C 928 Do iparent = locind_parent_left,locind_parent_last 929 pos=1 930 delta0=1./(epsilon+slope(iparent )**2)**2 931 delta1=1./(epsilon+slope(iparent+1)**2)**2 932 sumdelta = 1./(delta0+delta1) 933 Do jj = ipos - coeffraf/2+diffmod,ipos + coeffraf/2 934 C 935 ytemp(jj) = x(iparent)+(diff(pos)-0.5)*( 936 & delta0*slope(iparent)+ 937 & delta1*slope(iparent+1))*sumdelta 938 pos = pos+1 939 End do 940 ipos = ipos + coeffraf 941 C 942 End do 943 C 944 C 945 y(1:nc)=ytemp(1:nc) 946 deallocate(ytemp) 947 deallocate(diff) 948 949 Return 950 End Subroutine weno1d 951 684 952 C 685 953 C ************************************************************************** -
trunk/AGRIF/AGRIF_FILES/modlinktomodel.F
r396 r662 19 19 C 20 20 C 21 C22 21 Module Agrif_link 23 22 C … … 31 30 c external Agrif_detect 32 31 C 33 IMPLICIT NONE34 32 external Agrif_probdim_modtype_def 35 33 external Agrif_clustering_def … … 40 38 TYPE(Agrif_Grid), Pointer :: Agrif_Gr ! Pointer on the current grid 41 39 End Subroutine Agrif_Set_numberofcells 42 40 End interface 41 Interface 43 42 Subroutine Agrif_Get_numberofcells(Agrif_Gr) 44 43 Use Agrif_Types, Only : Agrif_grid 45 44 TYPE(Agrif_Grid), Pointer :: Agrif_Gr ! Pointer on the current grid 46 45 End Subroutine Agrif_Get_numberofcells 47 46 End interface 47 Interface 48 48 Subroutine Agrif_Allocationcalls(Agrif_Gr) 49 49 Use Agrif_Types, Only : Agrif_grid … … 51 51 End Subroutine Agrif_Allocationcalls 52 52 End interface 53 53 C 54 54 End Module Agrif_link 55 55 C ************************************************************************** -
trunk/AGRIF/AGRIF_FILES/modmask.F
r396 r662 202 202 C Local scalar 203 203 INTEGER :: i,ii,iii,jj,kk,ll,mm,nn 204 INTEGER,DIMENSION(nbdim) :: imin,imax 204 INTEGER,DIMENSION(nbdim) :: imin,imax,idecal 205 205 INTEGER :: Nbvals 206 206 REAL :: Res … … 235 235 imin(iii) = max(indic(iii) - i,ppbtab(iii)) 236 236 imax(iii) = min(indic(iii) + i,ppetab(iii)) 237 if (firsttest) then 238 if (indic(iii).GT.ppbtab(iii)) then 239 240 idecal = indic 241 idecal(iii) = idecal(iii)-1 242 SELECT CASE(nbdim) 243 CASE (1) 244 if (tempP%var%array1(idecal(1) 245 & ) == Agrif_SpecialValue) then 246 imin(iii) = imax(iii) 247 endif 248 CASE (2) 249 if (tempP%var%array2(idecal(1), 250 & idecal(2)) == Agrif_SpecialValue) then 251 imin(iii) = imax(iii) 252 endif 253 CASE (3) 254 if (tempP%var%array3(idecal(1), 255 & idecal(2),idecal(3)) 256 & == Agrif_SpecialValue) then 257 imin(iii) = imax(iii) 258 endif 259 CASE (4) 260 if (tempP%var%array4(idecal(1), 261 & idecal(2),idecal(3),idecal(4)) 262 & == Agrif_SpecialValue) then 263 imin(iii) = imax(iii) 264 endif 265 CASE (5) 266 if (tempP%var%array5(idecal(1), 267 & idecal(2),idecal(3),idecal(4),idecal(5)) 268 & == Agrif_SpecialValue) then 269 imin(iii) = imax(iii) 270 endif 271 CASE (6) 272 if (tempP%var%array6(idecal(1), 273 & idecal(2),idecal(3),idecal(4),idecal(5),idecal(6)) 274 & == Agrif_SpecialValue) then 275 imin(iii) = imax(iii) 276 endif 277 END SELECT 278 endif 279 endif 237 280 endif 238 281 enddo … … 241 284 Nbvals = 0 242 285 C 243 if ( nbdim .EQ. 1 ) then 286 SELECT CASE(nbdim) 287 CASE (1) 244 288 do ii = imin(1),imax(1) 245 289 ValParent = parent%var%array1(ii) … … 249 293 endif 250 294 enddo 251 endif 252 C 253 if ( nbdim .EQ. 2 ) then 295 C 296 CASE (2) 254 297 do jj = imin(2),imax(2) 255 298 do ii = imin(1),imax(1) … … 261 304 enddo 262 305 enddo 263 endif 264 C 265 if ( nbdim .EQ. 3 ) then 306 307 CASE (3) 266 308 do kk = imin(3),imax(3) 267 309 do jj = imin(2),imax(2) … … 275 317 enddo 276 318 enddo 277 endif 278 C 279 if ( nbdim .EQ. 4 ) then 319 320 CASE (4) 280 321 do ll = imin(4),imax(4) 281 322 do kk = imin(3),imax(3) … … 291 332 enddo 292 333 enddo 293 endif 294 C 295 if ( nbdim .EQ. 5 ) then 334 335 CASE (5) 296 336 do mm = imin(5),imax(5) 297 337 do ll = imin(4),imax(4) … … 309 349 enddo 310 350 enddo 311 endif 312 C 313 if ( nbdim .EQ. 6 ) then 351 352 CASE (6) 314 353 do nn = imin(6),imax(6) 315 354 do mm = imin(5),imax(5) … … 329 368 enddo 330 369 enddo 331 endif 370 371 END SELECT 332 372 C 333 373 C … … 336 376 if (firsttest) then 337 377 firsttest = .FALSE. 378 i=1 338 379 cycle 339 380 endif 340 if ( nbdim .EQ. 1 ) tempP%var%array1(indic(1)) 381 SELECT CASE(nbdim) 382 CASE (1) 383 tempP%var%array1(indic(1)) 341 384 & = Res/Nbvals 342 if ( nbdim .EQ. 2 ) tempP%var%array2(indic(1), 385 CASE (2) 386 tempP%var%array2(indic(1), 343 387 & indic(2)) = Res/Nbvals 344 if ( nbdim .EQ. 3 ) tempP%var%array3(indic(1), 388 CASE (3) 389 tempP%var%array3(indic(1), 345 390 & indic(2),indic(3)) = Res/Nbvals 346 if ( nbdim .EQ. 4 ) tempP%var%array4(indic(1), 391 CASE (4) 392 tempP%var%array4(indic(1), 347 393 & indic(2),indic(3),indic(4)) 348 394 & = Res/Nbvals 349 if ( nbdim .EQ. 5 ) tempP%var%array5(indic(1), 395 CASE (5) 396 tempP%var%array5(indic(1), 350 397 & indic(2),indic(3),indic(4), 351 398 & indic(5)) = Res/Nbvals 352 if ( nbdim .EQ. 6 ) tempP%var%array6(indic(1), 399 CASE (6) 400 tempP%var%array6(indic(1), 353 401 & indic(2),indic(3),indic(4), 354 402 & indic(5),indic(6)) = Res/Nbvals 403 END SELECT 355 404 exit 356 405 else -
trunk/AGRIF/AGRIF_FILES/modmpp.F
r396 r662 34 34 Subroutine Get_External_Data(tempC,tempCextend,pttruetab, 35 35 & cetruetab,pttruetabwhole,cetruetabwhole,nbdim,memberin, 36 & memberout )36 & memberout,memberoutall1) 37 37 38 38 IMPLICIT NONE … … 54 54 & cetruetab2 55 55 LOGICAL :: memberout1(1),memberoutall(0:Agrif_Nbprocs-1) 56 LOGICAL, OPTIONAL :: memberoutall1(0:Agrif_Nbprocs-1) 56 57 INTEGER :: code 57 58 … … 60 61 61 62 63 IF (present(memberoutall1)) THEN 64 memberoutall = memberoutall1 65 ELSE 62 66 memberout1(1) = memberout 63 67 64 68 CALL MPI_ALLGATHER(memberout1,1,MPI_LOGICAL,memberoutall, 65 69 & 1,MPI_LOGICAL,MPI_COMM_WORLD,code) 66 70 ENDIF 67 71 pttruetab2(:,Agrif_Procrank) = pttruetab(:,Agrif_Procrank) 68 72 cetruetab2(:,Agrif_Procrank) = cetruetab(:,Agrif_Procrank) … … 198 202 LOGICAL,DIMENSION(0:Agrif_Nbprocs-1) :: recvfromproc 199 203 LOGICAL :: res 200 TYPE(AGRIF_PVARIABLE) :: temprecv204 TYPE(AGRIF_PVARIABLE), SAVE :: temprecv 201 205 202 206 #include "mpif.h" … … 243 247 & MPI_COMM_WORLD,code) 244 248 CASE(3) 245 Call MPI_SEND(tempC%var%array3( 246 & imin(1,k):imax(1,k), 247 & imin(2,k):imax(2,k), 248 & imin(3,k):imax(3,k)), 249 & datasize,MPI_DOUBLE_PRECISION,k,etiquette, 250 & MPI_COMM_WORLD,code) 249 Call Agrif_Send_3Darray(tempC%var%array3, 250 & lbound(tempC%var%array3),imin(:,k),imax(:,k),k) 251 251 CASE(4) 252 252 Call MPI_SEND(tempC%var%array4( … … 311 311 enddo 312 312 313 313 IF (.Not.Associated(temprecv%var)) allocate(temprecv%var) 314 314 call Agrif_nbdim_allocation(temprecv%var,imin_recv(:,k), 315 315 & imax_recv(:,k),nbdim) … … 341 341 & MPI_COMM_WORLD,statut,code) 342 342 END SELECT 343 endif 343 344 345 Call MPI_SEND(sendtoproc(k),1,MPI_LOGICAL,k,etiquette, 346 & MPI_COMM_WORLD,code) 347 C 348 if (sendtoproc(k)) then 349 C 350 iminmax_temp(:,1,k) = imin(:,k) 351 iminmax_temp(:,2,k) = imax(:,k) 352 353 Call MPI_SEND(iminmax_temp(:,:,k), 354 & 2*nbdim,MPI_INTEGER,k,etiquette, 355 & MPI_COMM_WORLD,code) 356 C 357 SELECT CASE(nbdim) 358 CASE(1) 359 datasize=SIZE(tempC%var%array1( 360 & imin(1,k):imax(1,k))) 361 Call MPI_SEND(tempC%var%array1( 362 & imin(1,k):imax(1,k)), 363 & datasize,MPI_DOUBLE_PRECISION,k,etiquette, 364 & MPI_COMM_WORLD,code) 365 CASE(2) 366 datasize=SIZE(tempC%var%array2( 367 & imin(1,k):imax(1,k), 368 & imin(2,k):imax(2,k))) 369 Call MPI_SEND(tempC%var%array2( 370 & imin(1,k):imax(1,k), 371 & imin(2,k):imax(2,k)), 372 & datasize,MPI_DOUBLE_PRECISION,k,etiquette, 373 & MPI_COMM_WORLD,code) 374 CASE(3) 375 datasize=SIZE(tempC%var%array3( 376 & imin(1,k):imax(1,k), 377 & imin(2,k):imax(2,k), 378 & imin(3,k):imax(3,k))) 379 Call MPI_SEND(tempC%var%array3( 380 & imin(1,k):imax(1,k), 381 & imin(2,k):imax(2,k), 382 & imin(3,k):imax(3,k)), 383 & datasize,MPI_DOUBLE_PRECISION,k,etiquette, 384 & MPI_COMM_WORLD,code) 385 CASE(4) 386 datasize=SIZE(tempC%var%array4( 387 & imin(1,k):imax(1,k), 388 & imin(2,k):imax(2,k), 389 & imin(3,k):imax(3,k), 390 & imin(4,k):imax(4,k))) 391 Call MPI_SEND(tempC%var%array4( 392 & imin(1,k):imax(1,k), 393 & imin(2,k):imax(2,k), 394 & imin(3,k):imax(3,k), 395 & imin(4,k):imax(4,k)), 396 & datasize,MPI_DOUBLE_PRECISION,k,etiquette, 397 & MPI_COMM_WORLD,code) 398 CASE(5) 399 datasize=SIZE(tempC%var%array5( 400 & imin(1,k):imax(1,k), 401 & imin(2,k):imax(2,k), 402 & imin(3,k):imax(3,k), 403 & imin(4,k):imax(4,k), 404 & imin(5,k):imax(5,k))) 405 Call MPI_SEND(tempC%var%array5( 406 & imin(1,k):imax(1,k), 407 & imin(2,k):imax(2,k), 408 & imin(3,k):imax(3,k), 409 & imin(4,k):imax(4,k), 410 & imin(5,k):imax(5,k)), 411 & datasize,MPI_DOUBLE_PRECISION,k,etiquette, 412 & MPI_COMM_WORLD,code) 413 CASE(6) 414 datasize=SIZE(tempC%var%array6( 415 & imin(1,k):imax(1,k), 416 & imin(2,k):imax(2,k), 417 & imin(3,k):imax(3,k), 418 & imin(4,k):imax(4,k), 419 & imin(5,k):imax(5,k), 420 & imin(6,k):imax(6,k))) 421 Call MPI_SEND(tempC%var%array6( 422 & imin(1,k):imax(1,k), 423 & imin(2,k):imax(2,k), 424 & imin(3,k):imax(3,k), 425 & imin(4,k):imax(4,k), 426 & imin(5,k):imax(5,k), 427 & imin(6,k):imax(6,k)), 428 & datasize,MPI_DOUBLE_PRECISION,k,etiquette, 429 & MPI_COMM_WORLD,code) 430 END SELECT 431 C 432 endif 433 434 if (recvfromproc(k)) then 435 344 436 Call where_valtabtotab_mpi(tempCextend%var, 345 437 & temprecv%var,imin_recv(:,k),imax_recv(:,k),0.,nbdim) 346 438 347 439 Call Agrif_nbdim_deallocation(temprecv%var,nbdim) 348 deallocate(temprecv%var) 349 350 endif 351 352 C 353 enddo 354 355 356 do k = Agrif_ProcRank+1,Agrif_Nbprocs-1 357 C 358 C 359 Call MPI_SEND(sendtoproc(k),1,MPI_LOGICAL,k,etiquette, 360 & MPI_COMM_WORLD,code) 361 C 362 if (sendtoproc(k)) then 363 C 364 iminmax_temp(:,1,k) = imin(:,k) 365 iminmax_temp(:,2,k) = imax(:,k) 366 367 Call MPI_SEND(iminmax_temp(:,:,k), 368 & 2*nbdim,MPI_INTEGER,k,etiquette, 369 & MPI_COMM_WORLD,code) 370 C 371 datasize = 1 372 C 373 do i = 1,nbdim 374 C 375 datasize = datasize * (imax(i,k)-imin(i,k)+1) 376 C 377 enddo 378 C 379 SELECT CASE(nbdim) 380 CASE(1) 381 Call MPI_SEND(tempC%var%array1( 382 & imin(1,k):imax(1,k)), 383 & datasize,MPI_DOUBLE_PRECISION,k,etiquette, 384 & MPI_COMM_WORLD,code) 385 CASE(2) 386 Call MPI_SEND(tempC%var%array2( 387 & imin(1,k):imax(1,k), 388 & imin(2,k):imax(2,k)), 389 & datasize,MPI_DOUBLE_PRECISION,k,etiquette, 390 & MPI_COMM_WORLD,code) 391 CASE(3) 392 Call MPI_SEND(tempC%var%array3( 393 & imin(1,k):imax(1,k), 394 & imin(2,k):imax(2,k), 395 & imin(3,k):imax(3,k)), 396 & datasize,MPI_DOUBLE_PRECISION,k,etiquette, 397 & MPI_COMM_WORLD,code) 398 CASE(4) 399 Call MPI_SEND(tempC%var%array4( 400 & imin(1,k):imax(1,k), 401 & imin(2,k):imax(2,k), 402 & imin(3,k):imax(3,k), 403 & imin(4,k):imax(4,k)), 404 & datasize,MPI_DOUBLE_PRECISION,k,etiquette, 405 & MPI_COMM_WORLD,code) 406 CASE(5) 407 Call MPI_SEND(tempC%var%array5( 408 & imin(1,k):imax(1,k), 409 & imin(2,k):imax(2,k), 410 & imin(3,k):imax(3,k), 411 & imin(4,k):imax(4,k), 412 & imin(5,k):imax(5,k)), 413 & datasize,MPI_DOUBLE_PRECISION,k,etiquette, 414 & MPI_COMM_WORLD,code) 415 CASE(6) 416 Call MPI_SEND(tempC%var%array6( 417 & imin(1,k):imax(1,k), 418 & imin(2,k):imax(2,k), 419 & imin(3,k):imax(3,k), 420 & imin(4,k):imax(4,k), 421 & imin(5,k):imax(5,k), 422 & imin(6,k):imax(6,k)), 423 & datasize,MPI_DOUBLE_PRECISION,k,etiquette, 424 & MPI_COMM_WORLD,code) 425 END SELECT 426 C 440 C deallocate(temprecv%var) 441 427 442 endif 428 443 … … 448 463 & MPI_COMM_WORLD,statut,code) 449 464 450 imin_recv(:,k) = iminmax_temp(:,1,k)451 imax_recv(:,k) = iminmax_temp(:,2,k)452 453 datasize = 1454 C 455 do i = 1,nbdim456 C 457 datasize = datasize * (imax_recv(i,k)-imin_recv(i,k)+1)458 C 459 enddo460 461 call Agrif_nbdim_allocation(temprecv%var, imin_recv(:,k),462 & im ax_recv(:,k),nbdim)465 C imin_recv(:,k) = iminmax_temp(:,1,k) 466 C imax_recv(:,k) = iminmax_temp(:,2,k) 467 468 C datasize = 1 469 C 470 C do i = 1,nbdim 471 C 472 C datasize = datasize * (imax_recv(i,k)-imin_recv(i,k)+1) 473 C 474 C enddo 475 IF (.Not.Associated(temprecv%var)) allocate(temprecv%var) 476 call Agrif_nbdim_allocation(temprecv%var, 477 & iminmax_temp(:,1,k),iminmax_temp(:,2,k),nbdim) 463 478 SELECT CASE(nbdim) 464 479 CASE(1) 480 datasize=SIZE(temprecv%var%array1) 465 481 Call MPI_RECV(temprecv%var%array1, 466 482 & datasize,MPI_DOUBLE_PRECISION,k,etiquette, 467 483 & MPI_COMM_WORLD,statut,code) 468 484 CASE(2) 485 datasize=SIZE(temprecv%var%array2) 469 486 Call MPI_RECV(temprecv%var%array2, 470 487 & datasize,MPI_DOUBLE_PRECISION,k,etiquette, 471 488 & MPI_COMM_WORLD,statut,code) 472 489 CASE(3) 490 datasize=SIZE(temprecv%var%array3) 473 491 Call MPI_RECV(temprecv%var%array3, 474 492 & datasize,MPI_DOUBLE_PRECISION,k,etiquette, … … 476 494 477 495 CASE(4) 496 datasize=SIZE(temprecv%var%array4) 478 497 Call MPI_RECV(temprecv%var%array4, 479 498 & datasize,MPI_DOUBLE_PRECISION,k,etiquette, 480 499 & MPI_COMM_WORLD,statut,code) 481 500 CASE(5) 501 datasize=SIZE(temprecv%var%array5) 482 502 Call MPI_RECV(temprecv%var%array5, 483 503 & datasize,MPI_DOUBLE_PRECISION,k,etiquette, 484 504 & MPI_COMM_WORLD,statut,code) 485 505 CASE(6) 506 datasize=SIZE(temprecv%var%array6) 486 507 Call MPI_RECV(temprecv%var%array6, 487 508 & datasize,MPI_DOUBLE_PRECISION,k,etiquette, … … 490 511 491 512 Call where_valtabtotab_mpi(tempCextend%var, 492 & temprecv%var,imin_recv(:,k),imax_recv(:,k),0.,nbdim) 513 & temprecv%var,iminmax_temp(:,1,k),iminmax_temp(:,2,k) 514 & ,0.,nbdim) 493 515 494 516 Call Agrif_nbdim_deallocation(temprecv%var,nbdim) 495 deallocate(temprecv%var)517 C deallocate(temprecv%var) 496 518 endif 497 519 … … 500 522 501 523 End Subroutine ExchangeSamelevel 524 525 Subroutine Agrif_Send_3Darray(tab3D,bounds,imin,imax,k) 526 integer, dimension(3) :: bounds, imin, imax 527 real,dimension(bounds(1):,bounds(2):,bounds(3):),target 528 & :: tab3D 529 integer :: k 530 integer :: etiquette = 100 531 integer :: datasize, code 532 #include "mpif.h" 533 534 datasize = SIZE(tab3D( 535 & imin(1):imax(1), 536 & imin(2):imax(2), 537 & imin(3):imax(3))) 538 539 Call MPI_SEND(tab3D( 540 & imin(1):imax(1), 541 & imin(2):imax(2), 542 & imin(3):imax(3)), 543 & datasize,MPI_DOUBLE_PRECISION,k,etiquette, 544 & MPI_COMM_WORLD,code) 545 546 End Subroutine Agrif_Send_3Darray 502 547 503 548 #else -
trunk/AGRIF/AGRIF_FILES/modsauv.F
r396 r662 156 156 Deallocate(Agrif_Gr%tabvars(i)%var%interpIndex) 157 157 endif 158 159 if (associated(Agrif_Gr%tabvars(i)%var%posvar)) then 160 Deallocate(Agrif_Gr%tabvars(i)%var%posvar) 161 endif 162 163 if (associated(Agrif_Gr%tabvars(i)%var%interptab)) then 164 Deallocate(Agrif_Gr%tabvars(i)%var%interptab) 165 endif 166 158 167 C 159 168 Deallocate(Agrif_Gr%tabvars(i)%var) … … 291 300 Deallocate(Agrif_Gr%tabvars(i)%var%interpIndex) 292 301 endif 302 303 if (associated(Agrif_Gr%tabvars(i)%var%posvar)) then 304 Deallocate(Agrif_Gr%tabvars(i)%var%posvar) 305 endif 306 307 if (associated(Agrif_Gr%tabvars(i)%var%interptab)) then 308 Deallocate(Agrif_Gr%tabvars(i)%var%interptab) 309 endif 293 310 ! 294 311 Deallocate(Agrif_Gr%tabvars(i)%var) … … 349 366 eps = min(g_eps,oldgrid_eps)/100. 350 367 C 368 do iii = 1 , Agrif_Probdim 351 369 352 do iii = 1 , Agrif_Probdim353 370 if (g % Agrif_d(iii) .LT. 354 371 & (parcours % gr % Agrif_d(iii) - eps)) then … … 358 375 out = 1 359 376 C 360 Cycle377 Exit 361 378 C 362 379 endif -
trunk/AGRIF/AGRIF_FILES/modtypes.F
r396 r662 29 29 C 30 30 IMPLICIT NONE 31 32 C Maximum refinement ratio 33 34 INTEGER, PARAMETER :: Agrif_MaxRaff = 7 31 35 C 32 36 C ************************************************************************** … … 156 160 INTEGER ,DIMENSION(:,:) ,Pointer :: tabpoint2D 157 161 INTEGER ,DIMENSION(:,:,:) ,Pointer :: tabpoint3D 162 163 Type(Agrif_Flux), Pointer :: fluxes => NULL() 158 164 End TYPE Agrif_grid 159 165 C … … 191 197 REAL , DIMENSION(:,:,:,:,:,:),Pointer :: array6 => NULL() 192 198 C Arrays containing the values of the grid variables (REAL*8) 193 REAL (8):: darray0194 REAL (8), DIMENSION(:) ,Pointer :: darray1 => NULL()195 REAL (8), DIMENSION(:,:) ,Pointer :: darray2 => NULL()196 REAL (8), DIMENSION(:,:,:) ,Pointer :: darray3 => NULL()197 REAL (8), DIMENSION(:,:,:,:) ,Pointer :: darray4 => NULL()198 REAL (8), DIMENSION(:,:,:,:,:) ,Pointer :: darray5 => NULL()199 REAL (8), DIMENSION(:,:,:,:,:,:),Pointer :: darray6 => NULL()199 REAL*8 :: darray0 200 REAL*8, DIMENSION(:) ,Pointer :: darray1 => NULL() 201 REAL*8, DIMENSION(:,:) ,Pointer :: darray2 => NULL() 202 REAL*8, DIMENSION(:,:,:) ,Pointer :: darray3 => NULL() 203 REAL*8, DIMENSION(:,:,:,:) ,Pointer :: darray4 => NULL() 204 REAL*8, DIMENSION(:,:,:,:,:) ,Pointer :: darray5 => NULL() 205 REAL*8, DIMENSION(:,:,:,:,:,:),Pointer :: darray6 => NULL() 200 206 C Arrays containing the values of the grid variables (LOGICAL) 201 207 LOGICAL :: larray0 … … 240 246 INTEGER, DIMENSION(6) :: TYPEinterp ! option interp 241 247 INTEGER, DIMENSION(6) :: TYPEupdate ! option update 242 C 243 End TYPE Agrif_Variable 248 249 Type(Agrif_List_Interp_Loc), Pointer :: list_interp => NULL() 250 Type(Agrif_List_Interp_Loc), Pointer :: list_update => NULL() 251 C 252 End TYPE Agrif_Variable 253 254 Type Agrif_Interp_Loc 255 integer,dimension(6) :: pttab,petab, 256 & pttab_Child,pttab_Parent = -99 257 integer,dimension(6) :: indmin, indmax 258 INTEGER,DIMENSION(6) :: pttruetab,cetruetab 259 logical :: member, memberin 260 #if !defined AGRIF_MPI 261 integer,dimension(6) :: indminglob,indmaxglob 262 #else 263 integer,dimension(6) :: indminglob2,indmaxglob2 264 INTEGER,DIMENSION(6,2,2) :: parentarray 265 INTEGER,DIMENSION(:,:,:), POINTER :: tab4t 266 LOGICAL, DIMENSION(:), POINTER :: memberinall 267 INTEGER,DIMENSION(:,:,:), POINTER :: tab5t 268 LOGICAL, DIMENSION(:), POINTER :: memberinall2 269 #endif 270 End Type Agrif_Interp_Loc 271 272 Type Agrif_List_Interp_Loc 273 Type(Agrif_Interp_Loc), Pointer :: interp_loc 274 Type(Agrif_List_Interp_Loc), Pointer :: suiv 275 End Type Agrif_List_Interp_Loc 276 277 TYPE Agrif_Profile 278 character*80 :: profilename 279 C 280 ! index of the first point in the REAL domain (x,y and z direction) 281 INTEGER ,DIMENSION(6) :: point 282 ! position of the variable on the cell (1 for the boarder of 283 ! the edge, 2 for the center) 284 INTEGER ,DIMENSION(:) ,Pointer :: posvar => NULL() 285 ! Indication for the space interpolation (module Agrif_Boundary) 286 INTEGER ,Pointer :: interpIndex => NULL() 287 ! number of DIMENSIONs of the grid variable 288 INTEGER :: nbdim = 0 289 ! Array indicating the TYPE of DIMENSION (space or not) for 290 ! each of them 291 CHARACTER(6),DIMENSION(:) ,Pointer :: interptab => NULL() 292 Type(Agrif_Profile), Pointer :: nextprofile => NULL() 293 END TYPE Agrif_Profile 294 295 Type(Agrif_Profile), Pointer :: Agrif_MyProfiles => NULL() 296 297 C Boundaries Fluxes 298 299 Type Agrif_Flux 300 Character*80 fluxname 301 Type(Agrif_Variable), Pointer :: fluxtabx 302 Type(Agrif_Variable), Pointer :: fluxtaby 303 Type(Agrif_Variable), Pointer :: fluxtabz 304 Type(Agrif_Profile), Pointer :: profile 305 Logical :: Fluxallocated = .FALSE. 306 Type(Agrif_Flux), Pointer :: nextflux => NULL() 307 End Type Agrif_Flux 244 308 C 245 309 C ************************************************************************** … … 285 349 INTEGER :: Agrif_Regridding 286 350 INTEGER :: Agrif_Minwidth 287 REAL :: Agrif_Efficiency 351 REAL :: Agrif_Efficiency = 0.7 288 352 REAL ,DIMENSION(3) :: Agrif_mind 289 353 C PARAMETERs for the interpolation of the child grids … … 302 366 ! linear conservative interpolation 303 367 INTEGER ,PARAMETER :: Agrif_linearconservlim=7 304 INTEGER ,PARAMETER :: Agrif_ppm=8 368 INTEGER ,PARAMETER :: Agrif_ppm=8 369 INTEGER ,PARAMETER :: Agrif_weno=9 305 370 C PARAMETERs for the update of the parent grids 306 371 INTEGER ,PARAMETER :: Agrif_Update_Copy=1 ! copy -
trunk/AGRIF/AGRIF_FILES/modupdate.F
r396 r662 85 85 C 86 86 C Values on the current grid used for the update 87 childtemp % var % array1 => tab 87 childtemp % var % array1 => tab 88 89 C childtemp % var % list_update => child%var%list_update 90 88 91 C 89 92 … … 96 99 ENDIF 97 100 C 101 C child % var % list_update => childtemp%var%list_update 102 98 103 deallocate(childtemp % var) 99 104 C … … 146 151 C Values on the current grid used for the update 147 152 childtemp % var % array2 => tab 153 154 C childtemp % var % list_update => child%var%list_update 148 155 C 149 156 IF (present(procname)) THEN … … 155 162 ENDIF 156 163 C 164 C child % var % list_update => childtemp%var%list_update 165 157 166 deallocate(childtemp % var) 158 167 C … … 204 213 C Values on the current grid used for the update 205 214 childtemp % var % array3 => tab 215 216 C childtemp % var % list_update => child%var%list_update 206 217 C 207 218 IF (present(procname)) THEN … … 213 224 ENDIF 214 225 C 226 C child % var % list_update => childtemp%var%list_update 227 215 228 DEALLOCATE(childtemp % var) 216 229 C … … 262 275 C Values on the current grid used for the update 263 276 childtemp % var % array4 => tab 277 278 C childtemp % var % list_update => child%var%list_update 279 264 280 C 265 281 IF (present(procname)) THEN … … 270 286 & (TypeUpdate,parent,child,deb,fin) 271 287 ENDIF 288 289 C child % var % list_update => childtemp%var%list_update 272 290 C 273 291 deallocate(childtemp % var) … … 322 340 C Values on the current grid used for the update 323 341 childtemp % var % array5 => tab 342 343 C childtemp % var % list_update => child%var%list_update 324 344 C 325 345 IF (present(procname)) THEN … … 330 350 & (TypeUpdate,parent,child,deb,fin) 331 351 ENDIF 352 353 C child % var % list_update => childtemp%var%list_update 354 332 355 C 333 356 deallocate(childtemp % var) … … 380 403 C Values on the current grid used for the update 381 404 childtemp % var % array6 => tab 405 C childtemp % var % list_update => child%var%list_update 382 406 C 383 407 Call Agrif_UpdateVariable 384 408 & (TypeUpdate,parent,child,deb,fin) 409 410 C child % var % list_update => childtemp%var%list_update 411 385 412 C 386 413 deallocate(childtemp % var) … … 658 685 659 686 IF (posvartab_child(i) == 1) THEN 660 IF (TypeUpdate(i) .NE. Agrif_Update_Copy) THEN 687 IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN 688 indtab(i,1,1) = indtab(i,1,1) - (coeffraf - 1) 689 indtab(i,1,2) = indtab(i,1,2) + (coeffraf - 1) 690 ELSE IF (TypeUpdate(i) .NE. Agrif_Update_Copy) THEN 661 691 indtab(i,1,1) = indtab(i,1,1) - coeffraf / 2 662 692 indtab(i,1,2) = indtab(i,1,2) + coeffraf / 2 … … 665 695 indtab(i,1,1) = indtab(i,1,1) - coeffraf 666 696 indtab(i,1,2) = indtab(i,1,2) - 1 697 IF ((TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) 698 & .AND.(mod(coeffraf,2) == 1)) THEN 699 indtab(i,1,1) = indtab(i,1,1) - 1 700 indtab(i,1,2) = indtab(i,1,2) + 1 701 ENDIF 667 702 ENDIF 668 703 IF (loctab_child(i) == -3) THEN … … 832 867 833 868 IF (posvartab_child(i) == 1) THEN 834 IF (TypeUpdate(i) .NE. Agrif_Update_Copy) THEN 869 IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN 870 indtab(i,:,1) = indtab(i,:,1) - (coeffraf - 1) 871 indtab(i,:,2) = indtab(i,:,2) + (coeffraf - 1) 872 ELSE IF (TypeUpdate(i) .NE. Agrif_Update_Copy) THEN 835 873 indtab(i,:,1) = indtab(i,:,1) - coeffraf / 2 836 874 indtab(i,:,2) = indtab(i,:,2) + coeffraf / 2 … … 840 878 indtab(i,1,2) = indtab(i,1,2) - 1 841 879 indtab(i,2,2) = indtab(i,2,2) + coeffraf - 1 880 IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN 881 indtab(i,1,1) = indtab(i,1,1) - 1 882 indtab(i,1,2) = indtab(i,1,2) + 1 883 indtab(i,2,1) = indtab(i,2,1) - 1 884 indtab(i,2,2) = indtab(i,2,2) + 1 885 ENDIF 842 886 ENDIF 843 887 ENDDO … … 952 996 & ds_Child(1:nbdim),ds_Parent(1:nbdim), 953 997 & posvartab_Child,loctab_Child, 954 & nbdim,procname )998 & nbdim,procname,nb,ndir) 955 999 ELSE 956 1000 Call Agrif_UpdatenD … … 985 1029 & ds_Child,ds_Parent, 986 1030 & posvartab_Child,loctab_Child, 987 & nbdim,procname )1031 & nbdim,procname,nb,ndir) 988 1032 C 989 1033 C Description: … … 1030 1074 External :: procname 1031 1075 Optional :: procname 1076 Integer :: nb,ndir 1077 Optional :: nb,ndir 1078 1032 1079 C 1033 1080 C Local pointers 1034 TYPE(AGRIF_PVARIABLE) :: tempP ! Temporary parent grid variable1035 TYPE(AGRIF_PVARIABLE) :: tempC ! Temporary child grid variable1081 TYPE(AGRIF_PVARIABLE), SAVE :: tempP ! Temporary parent grid variable 1082 TYPE(AGRIF_PVARIABLE), SAVE :: tempC ! Temporary child grid variable 1036 1083 C 1037 1084 C Local scalars … … 1047 1094 INTEGER,DIMENSION(nbdim,2,2) :: childarray 1048 1095 INTEGER,DIMENSION(nbdim,2,2) :: parentarray 1049 TYPE(AGRIF_PVARIABLE) :: tempCextend,tempPextend ! Temporary child1050 ! grid1096 TYPE(AGRIF_PVARIABLE), SAVE :: tempCextend,tempPextend ! Temporary child 1097 INTEGER :: nbin, ndirin 1051 1098 C 1052 1099 #ifdef AGRIF_MPI … … 1057 1104 INTEGER,DIMENSION(nbdim,4) :: tab3 1058 1105 INTEGER,DIMENSION(nbdim,4,0:Agrif_Nbprocs-1) :: tab4 1059 INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,4) :: tab4t 1060 ccccccccccccccc TYPE(AGRIF_PVARIABLE) :: childvalues 1106 INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,4) :: tab4t, tab5t 1107 LOGICAL :: find_list_update 1108 LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: memberinall, memberinall2 1109 LOGICAL, DIMENSION(1) :: memberin1 1061 1110 C 1062 1111 #endif … … 1119 1168 #endif 1120 1169 1121 1170 IF (present(procname)) THEN 1171 IF (.Not.present(nb)) THEN 1172 nbin=0 1173 ndirin=0 1174 ELSE 1175 nbin = nb 1176 ndirin = ndir 1177 ENDIF 1178 ENDIF 1179 1122 1180 IF (memberin) THEN 1123 allocate(tempC%var)1181 IF (.not.associated(tempC%var)) allocate(tempC%var) 1124 1182 1125 1183 C … … 1136 1194 CALL procname(tempC%var%array1, 1137 1195 & childarray(1,1,2),childarray(1,2,2), 1138 & .TRUE. )1196 & .TRUE.,nbin,ndirin) 1139 1197 CASE(2) 1140 1198 CALL procname(tempC%var%array2, 1141 1199 & childarray(1,1,2),childarray(1,2,2), 1142 1200 & childarray(2,1,2),childarray(2,2,2), 1143 & .TRUE. )1201 & .TRUE.,nbin,ndirin) 1144 1202 CASE(3) 1145 1203 CALL procname(tempC%var%array3, … … 1147 1205 & childarray(2,1,2),childarray(2,2,2), 1148 1206 & childarray(3,1,2),childarray(3,2,2), 1149 & .TRUE. )1207 & .TRUE.,nbin,ndirin) 1150 1208 CASE(4) 1151 1209 CALL procname(tempC%var%array4, … … 1154 1212 & childarray(3,1,2),childarray(3,2,2), 1155 1213 & childarray(4,1,2),childarray(4,2,2), 1156 & .TRUE. )1214 & .TRUE.,nbin,ndirin) 1157 1215 CASE(5) 1158 1216 CALL procname(tempC%var%array5, … … 1162 1220 & childarray(4,1,2),childarray(4,2,2), 1163 1221 & childarray(5,1,2),childarray(5,2,2), 1164 & .TRUE. )1222 & .TRUE.,nbin,ndirin) 1165 1223 CASE(6) 1166 1224 CALL procname(tempC%var%array6, … … 1171 1229 & childarray(5,1,2),childarray(5,2,2), 1172 1230 & childarray(6,1,2),childarray(6,2,2), 1173 & .TRUE. )1231 & .TRUE.,nbin,ndirin) 1174 1232 END SELECT 1175 1233 ELSE … … 1189 1247 C tab2 contains the necessary limits of the parent grid for each processor 1190 1248 1249 IF (Associated(child%var%list_update)) THEN 1250 Call Agrif_Find_list_update(child%var%list_update,pttab,petab, 1251 & pttab_Child,pttab_Parent,nbdim, 1252 & find_list_update,tab4t,tab5t,memberinall,memberinall2) 1253 ELSE 1254 find_list_update = .FALSE. 1255 ENDIF 1256 1257 if (.not.find_list_update) then 1191 1258 tab3(:,1) = pttruetab(:) 1192 1259 tab3(:,2) = cetruetab(:) … … 1198 1265 & MPI_INTEGER,MPI_COMM_WORLD,code) 1199 1266 1200 Allocate(tempCextend%var)1267 IF (.not.associated(tempCextend%var)) Allocate(tempCextend%var) 1201 1268 DO k=0,Agrif_Nbprocs-1 1202 1269 do j=1,4 … … 1206 1273 enddo 1207 1274 enddo 1275 1276 memberin1(1) = memberin 1277 CALL MPI_ALLGATHER(memberin1,1,MPI_LOGICAL,memberinall, 1278 & 1,MPI_LOGICAL,MPI_COMM_WORLD,code) 1279 1280 endif 1281 1208 1282 Call Get_External_Data(tempC,tempCextend,tab4t(:,:,1), 1209 1283 & tab4t(:,:,2), 1210 & tab4t(:,:,3),tab4t(:,:,4),nbdim,memberin,memberin) 1284 & tab4t(:,:,3),tab4t(:,:,4),nbdim,memberin,memberin, 1285 & memberinall) 1211 1286 1212 1287 #else … … 1221 1296 IF (memberin) THEN 1222 1297 1223 allocate(tempP%var)1298 IF (.not.associated(tempP%var)) allocate(tempP%var) 1224 1299 Call Agrif_nbdim_allocation(tempP%var, 1225 1300 & indmin,indmax,nbdim) … … 1276 1351 1277 1352 Call Agrif_nbdim_deallocation(tempCextend%var,nbdim) 1278 Deallocate(tempCextend%var)1353 C Deallocate(tempCextend%var) 1279 1354 1280 1355 ENDIF … … 1301 1376 Call Agrif_ParentGrid_to_ChildGrid() 1302 1377 1378 if (.not.find_list_update) then 1303 1379 tab3(:,1) = indmin(:) 1304 1380 tab3(:,2) = indmax(:) … … 1309 1385 & MPI_INTEGER,MPI_COMM_WORLD,code) 1310 1386 1311 Allocate(tempPextend%var)1387 IF (.not.associated(tempPextend%var)) Allocate(tempPextend%var) 1312 1388 DO k=0,Agrif_Nbprocs-1 1313 1389 do j=1,4 1314 1390 do i=1,nbdim 1315 tab 4t(i,k,j) = tab4(i,j,k)1391 tab5t(i,k,j) = tab4(i,j,k) 1316 1392 enddo 1317 1393 enddo 1318 1394 enddo 1319 Call Get_External_Data(tempP,tempPextend,tab4t(:,:,1), 1320 & tab4t(:,:,2), 1321 & tab4t(:,:,3),tab4t(:,:,4),nbdim,memberin,member) 1395 1396 memberin1(1) = member 1397 CALL MPI_ALLGATHER(memberin1,1,MPI_LOGICAL,memberinall2, 1398 & 1,MPI_LOGICAL,MPI_COMM_WORLD,code) 1399 1400 Call Agrif_Addto_list_update(child%var%list_update,pttab,petab, 1401 & pttab_Child,pttab_Parent,nbdim 1402 & ,tab4t,tab5t,memberinall,memberinall2) 1403 1404 endif 1405 1406 Call Get_External_Data(tempP,tempPextend,tab5t(:,:,1), 1407 & tab5t(:,:,2), 1408 & tab5t(:,:,3),tab5t(:,:,4),nbdim,memberin,member, 1409 & memberinall2) 1322 1410 1323 1411 #else … … 1407 1495 & parentarray(1,1,1):parentarray(1,2,1)), 1408 1496 & parentarray(1,1,2),parentarray(1,2,2), 1409 & .FALSE. 1497 & .FALSE.,nbin,ndirin 1410 1498 & ) 1411 1499 CASE(2) … … 1416 1504 & parentarray(1,1,2),parentarray(1,2,2), 1417 1505 & parentarray(2,1,2),parentarray(2,2,2), 1418 & .FALSE. 1506 & .FALSE.,nbin,ndirin 1419 1507 & ) 1420 1508 CASE(3) … … 1427 1515 & parentarray(2,1,2),parentarray(2,2,2), 1428 1516 & parentarray(3,1,2),parentarray(3,2,2), 1429 & .FALSE. 1517 & .FALSE.,nbin,ndirin 1430 1518 & ) 1431 1519 CASE(4) … … 1440 1528 & parentarray(3,1,2),parentarray(3,2,2), 1441 1529 & parentarray(4,1,2),parentarray(4,2,2), 1442 & .FALSE. 1530 & .FALSE.,nbin,ndirin 1443 1531 & ) 1444 1532 CASE(5) … … 1455 1543 & parentarray(4,1,2),parentarray(4,2,2), 1456 1544 & parentarray(5,1,2),parentarray(5,2,2), 1457 & .FALSE. 1545 & .FALSE.,nbin,ndirin 1458 1546 & ) 1459 1547 CASE(6) … … 1472 1560 & parentarray(5,1,2),parentarray(5,2,2), 1473 1561 & parentarray(6,1,2),parentarray(6,2,2), 1474 & .FALSE. 1562 & .FALSE.,nbin,ndirin 1475 1563 & ) 1476 1564 END SELECT … … 1545 1633 Call Agrif_nbdim_deallocation(tempP%var,nbdim) 1546 1634 Call Agrif_nbdim_deallocation(tempC%var,nbdim) 1547 Deallocate(tempC % var)1635 ! Deallocate(tempC % var) 1548 1636 #endif 1549 Deallocate(tempP % var)1637 ! Deallocate(tempP % var) 1550 1638 ENDIF 1551 1639 #ifdef AGRIF_MPI 1552 Deallocate(tempPextend%var)1553 IF (.Not.memberin) Deallocate(tempCextend%var)1640 ! Deallocate(tempPextend%var) 1641 ! IF (.Not.memberin) Deallocate(tempCextend%var) 1554 1642 #endif 1555 1643 … … 1628 1716 IF (loctab_Child(i) .NE. -3) THEN 1629 1717 IF (posvartab_child(i) == 1) THEN 1630 IF (TypeUpdate(i) .NE. Agrif_Update_Copy) THEN 1631 positionmin = positionmin - ds_Parent(i)/2. 1718 IF (TypeUpdate(i) .EQ. Agrif_Update_Average) THEN 1719 positionmin = positionmin - ds_Parent(i)/2. 1720 ELSE IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN 1721 positionmin = positionmin - (ds_Parent(i)-ds_Child(i)) 1632 1722 ENDIF 1633 1723 ELSE 1634 1724 positionmin = positionmin - ds_Parent(i)/2. 1725 IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN 1726 positionmin = positionmin - ds_Child(i) 1727 ENDIF 1635 1728 ENDIF 1636 1729 ENDIF … … 1647 1740 IF (loctab_Child(i) .NE. -3) THEN 1648 1741 IF (posvartab_child(i) == 1) THEN 1649 IF (TypeUpdate(i) . NE. Agrif_Update_Copy) THEN1742 IF (TypeUpdate(i) .EQ. Agrif_Update_Average) THEN 1650 1743 positionmax = positionmax + ds_Parent(i)/2. 1744 ELSE IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN 1745 positionmax = positionmax + (ds_Parent(i)-ds_Child(i)) 1651 1746 ENDIF 1652 1747 ELSE 1653 1748 positionmax = positionmax + ds_Parent(i)/2. 1749 IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN 1750 positionmax = positionmax + ds_Child(i) 1751 ENDIF 1654 1752 ENDIF 1655 1753 ENDIF … … 1684 1782 C 1685 1783 C 1686 C ************************************************************************** 1687 CCC Subroutine Agrif_Update_1D_Recursive 1688 C ************************************************************************** 1689 C 1690 Subroutine Agrif_Update_1D_recursive(TypeUpdate,tempP,tempC, 1691 & indmin,indmax, 1692 & pttab_child,petab_child, 1693 & s_child,s_parent, 1694 & ds_child,ds_parent,nbdim) 1695 C 1696 CCC Description: 1697 CCC Subroutine to update a 1D grid variable on the parent grid. 1698 C 1699 CC Method: 1700 C 1701 C Declarations: 1702 C 1703 1704 C 1705 C Arguments 1706 INTEGER :: nbdim 1707 INTEGER, DIMENSION(nbdim) :: TypeUpdate ! TYPE of update (copy or average) 1708 INTEGER, DIMENSION(nbdim) :: indmin,indmax 1709 INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child 1710 REAL, DIMENSION(nbdim) :: s_child,s_parent 1711 REAL, DIMENSION(nbdim) :: ds_child,ds_parent 1712 REAL, DIMENSION(indmin(nbdim):indmax(nbdim)) :: tempP 1713 REAL, DIMENSION(pttab_child(nbdim):petab_child(nbdim)) :: tempC 1714 C 1715 C 1716 Call Agrif_UpdateBase(TypeUpdate(1), 1717 & tempP(indmin(nbdim):indmax(nbdim)), 1718 & tempC(pttab_child(nbdim):petab_child(nbdim)), 1719 & indmin(nbdim),indmax(nbdim), 1720 & pttab_child(nbdim),petab_child(nbdim), 1721 & s_parent(nbdim),s_child(nbdim), 1722 & ds_parent(nbdim),ds_child(nbdim)) 1723 C 1724 Return 1725 C 1726 C 1727 End Subroutine Agrif_Update_1D_recursive 1784 1728 1785 C 1729 1786 C … … 1734 1791 C 1735 1792 Subroutine Agrif_Update_2D_recursive(TypeUpdate,tempP,tempC, 1736 & indmin,indmax, 1793 & indmin,indmax, 1737 1794 & pttab_child,petab_child, 1738 1795 & s_child,s_parent, … … 1757 1814 REAL, DIMENSION(indmin(1):indmax(1), 1758 1815 & indmin(2):indmax(2)) :: tempP 1759 REAL, DIMENSION(pttab_child(1):petab_child(1), 1760 & pttab_child(2):petab_child(2)) :: tempC 1816 C REAL, DIMENSION(pttab_child(1):petab_child(1), 1817 C & pttab_child(2):petab_child(2)) :: tempC 1818 1819 REAL, DIMENSION(:,:) :: tempC 1761 1820 C 1762 1821 C Local variables 1763 REAL, DIMENSION(:,:), Allocatable :: tabtemp 1822 REAL, DIMENSION(indmin(1):indmax(1), 1823 & pttab_child(2):petab_child(2)) :: tabtemp 1764 1824 INTEGER :: i,j 1765 C 1766 C 1767 Allocate(tabtemp(indmin(1):indmax(1), 1768 & pttab_child(2):petab_child(2))) 1825 INTEGER :: coeffraf,locind_child_left 1769 1826 C 1770 1827 do j = pttab_child(nbdim),petab_child(nbdim) 1771 1828 C 1772 Call Agrif_Update_1D_recursive(TypeUpdate ,1773 & tabtemp( indmin(nbdim-1):indmax(nbdim-1),j),1774 & tempC( pttab_child(nbdim-1):petab_child(nbdim-1),j),1829 Call Agrif_Update_1D_recursive(TypeUpdate(1:nbdim-1), 1830 & tabtemp(:,j), 1831 & tempC(:,j-pttab_child(nbdim)+1), 1775 1832 & indmin(1:nbdim-1),indmax(1:nbdim-1), 1776 1833 & pttab_child(1:nbdim-1),petab_child(1:nbdim-1), … … 1779 1836 C 1780 1837 enddo 1838 1839 Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim), 1840 & ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left) 1781 1841 C 1782 1842 do i = indmin(1),indmax(1) 1783 1843 C 1784 1844 Call Agrif_UpdateBase(TypeUpdate(2), 1785 & tempP(i, indmin(nbdim):indmax(nbdim)),1786 & tabtemp(i, pttab_child(nbdim):petab_child(nbdim)),1845 & tempP(i,:), 1846 & tabtemp(i,:), 1787 1847 & indmin(nbdim),indmax(nbdim), 1788 1848 & pttab_child(nbdim),petab_child(nbdim), 1789 1849 & s_parent(nbdim),s_child(nbdim), 1790 & ds_parent(nbdim),ds_child(nbdim)) 1850 & ds_parent(nbdim),ds_child(nbdim), 1851 & coeffraf,locind_child_left) 1791 1852 C 1792 1853 enddo 1793 C1794 Deallocate(tabtemp)1795 1854 C 1796 1855 Return … … 1835 1894 C 1836 1895 C Local variables 1837 REAL, DIMENSION(:,:,:), Allocatable :: tabtemp 1896 REAL, DIMENSION(indmin(1):indmax(1), 1897 & indmin(2):indmax(2), 1898 & pttab_child(3):petab_child(3)) :: tabtemp 1838 1899 INTEGER :: i,j,k 1839 C 1840 C 1841 Allocate(tabtemp(indmin(1):indmax(1), 1842 & indmin(2):indmax(2), 1843 & pttab_child(3):petab_child(3))) 1900 INTEGER :: coeffraf,locind_child_left 1901 INTEGER :: kdeb 1902 C 1844 1903 C 1845 1904 do k = pttab_child(nbdim),petab_child(nbdim) 1846 1905 C 1847 Call Agrif_Update_2D_recursive(TypeUpdate, 1848 & tabtemp(indmin(nbdim-2):indmax(nbdim-2), 1849 & indmin(nbdim-1):indmax(nbdim-1),k), 1850 & tempC(pttab_child(nbdim-2):petab_child(nbdim-2), 1851 & pttab_child(nbdim-1):petab_child(nbdim-1),k), 1906 Call Agrif_Update_2D_recursive(TypeUpdate(1:nbdim-1), 1907 & tabtemp(:,:,k), 1908 & tempC(:,:,k), 1852 1909 & indmin(1:nbdim-1),indmax(1:nbdim-1), 1853 1910 & pttab_child(1:nbdim-1),petab_child(1:nbdim-1), … … 1857 1914 enddo 1858 1915 C 1859 C 1916 Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim), 1917 & ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left) 1918 1919 IF (coeffraf == 1) THEN 1920 1921 kdeb = pttab_child(3)+locind_child_left-2 1922 do k=indmin(3),indmax(3) 1923 kdeb = kdeb + 1 1860 1924 do j = indmin(2),indmax(2) 1861 C1862 1925 do i = indmin(1),indmax(1) 1926 tempP(i,j,k) = tabtemp(i,j,kdeb) 1927 enddo 1928 enddo 1929 enddo 1930 1931 ELSE 1932 C 1933 do j = indmin(2),indmax(2) 1934 C 1935 do i = indmin(1),indmax(1) 1863 1936 C 1864 1937 Call Agrif_UpdateBase(TypeUpdate(3), 1865 & tempP(i,j, indmin(nbdim):indmax(nbdim)),1866 & tabtemp(i,j, pttab_child(nbdim):petab_child(nbdim)),1938 & tempP(i,j,:), 1939 & tabtemp(i,j,:), 1867 1940 & indmin(nbdim),indmax(nbdim), 1868 1941 & pttab_child(nbdim),petab_child(nbdim), 1869 1942 & s_parent(nbdim),s_child(nbdim), 1870 & ds_parent(nbdim),ds_child(nbdim)) 1943 & ds_parent(nbdim),ds_child(nbdim), 1944 & coeffraf,locind_child_left) 1871 1945 C 1872 1946 enddo 1873 1947 C 1874 1948 enddo 1875 C 1876 Deallocate(tabtemp) 1949 ENDIF 1877 1950 C 1878 1951 Return … … 1921 1994 REAL, DIMENSION(:,:,:,:), Allocatable :: tabtemp 1922 1995 INTEGER :: i,j,k,l 1996 INTEGER :: coeffraf,locind_child_left 1923 1997 C 1924 1998 C … … 1930 2004 do l = pttab_child(nbdim),petab_child(nbdim) 1931 2005 C 1932 Call Agrif_Update_3D_recursive(TypeUpdate ,2006 Call Agrif_Update_3D_recursive(TypeUpdate(1:nbdim-1), 1933 2007 & tabtemp(indmin(nbdim-3):indmax(nbdim-3), 1934 2008 & indmin(nbdim-2):indmax(nbdim-2), … … 1943 2017 C 1944 2018 enddo 2019 2020 Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim), 2021 & ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left) 1945 2022 C 1946 2023 do k = indmin(3),indmax(3) … … 1956 2033 & pttab_child(nbdim),petab_child(nbdim), 1957 2034 & s_parent(nbdim),s_child(nbdim), 1958 & ds_parent(nbdim),ds_child(nbdim)) 2035 & ds_parent(nbdim),ds_child(nbdim), 2036 & coeffraf,locind_child_left) 1959 2037 C 1960 2038 enddo … … 2013 2091 REAL, DIMENSION(:,:,:,:,:), Allocatable :: tabtemp 2014 2092 INTEGER :: i,j,k,l,m 2093 INTEGER :: coeffraf,locind_child_left 2015 2094 C 2016 2095 C … … 2023 2102 do m = pttab_child(nbdim),petab_child(nbdim) 2024 2103 C 2025 Call Agrif_Update_4D_recursive(TypeUpdate ,2104 Call Agrif_Update_4D_recursive(TypeUpdate(1:nbdim-1), 2026 2105 & tabtemp(indmin(nbdim-4):indmax(nbdim-4), 2027 2106 & indmin(nbdim-3):indmax(nbdim-3), … … 2038 2117 C 2039 2118 enddo 2119 2120 Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim), 2121 & ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left) 2040 2122 C 2041 2123 do l = indmin(4),indmax(4) … … 2054 2136 & pttab_child(nbdim),petab_child(nbdim), 2055 2137 & s_parent(nbdim),s_child(nbdim), 2056 & ds_parent(nbdim),ds_child(nbdim)) 2138 & ds_parent(nbdim),ds_child(nbdim), 2139 & coeffraf,locind_child_left) 2057 2140 C 2058 2141 enddo … … 2116 2199 REAL, DIMENSION(:,:,:,:,:,:), Allocatable :: tabtemp 2117 2200 INTEGER :: i,j,k,l,m,n 2201 INTEGER :: coeffraf,locind_child_left 2118 2202 C 2119 2203 C … … 2127 2211 do n = pttab_child(nbdim),petab_child(nbdim) 2128 2212 C 2129 Call Agrif_Update_5D_recursive(TypeUpdate ,2213 Call Agrif_Update_5D_recursive(TypeUpdate(1:nbdim-1), 2130 2214 & tabtemp(indmin(nbdim-5):indmax(nbdim-5), 2131 2215 & indmin(nbdim-4):indmax(nbdim-4), … … 2144 2228 C 2145 2229 enddo 2230 2231 Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim), 2232 & ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left) 2146 2233 C 2147 2234 do m = indmin(5),indmax(5) … … 2161 2248 & pttab_child(nbdim),petab_child(nbdim), 2162 2249 & s_parent(nbdim),s_child(nbdim), 2163 & ds_parent(nbdim),ds_child(nbdim)) 2250 & ds_parent(nbdim),ds_child(nbdim), 2251 & coeffraf,locind_child_left) 2164 2252 C 2165 2253 enddo … … 2188 2276 & parenttab,childtab, 2189 2277 & indmin,indmax,pttab_child,petab_child, 2190 & s_parent,s_child,ds_parent,ds_child) 2278 & s_parent,s_child,ds_parent,ds_child, 2279 & coeffraf,locind_child_left) 2191 2280 C 2192 2281 CCC Description: … … 2206 2295 REAL,DIMENSION(pttab_child:petab_child) :: childtab 2207 2296 REAL :: s_parent,s_child 2208 REAL :: ds_parent,ds_child 2297 REAL :: ds_parent,ds_child 2298 INTEGER :: coeffraf,locind_child_left 2209 2299 C 2210 2300 C 2211 2301 if (TypeUpdate == AGRIF_Update_copy) then 2212 2302 C 2213 Call copy1D2303 Call agrif_copy1D 2214 2304 & (parenttab,childtab, 2215 2305 & indmax-indmin+1,petab_child-pttab_child+1, … … 2228 2318 & (parenttab,childtab, 2229 2319 & indmax-indmin+1,petab_child-pttab_child+1, 2230 & s_parent,s_child,ds_parent,ds_child) 2320 & s_parent,s_child,ds_parent,ds_child, 2321 & coeffraf,locind_child_left) 2231 2322 C 2232 2323 endif … … 2238 2329 C 2239 2330 C 2331 2332 Subroutine Agrif_Compute_nbdim_update(s_parent,s_child, 2333 & ds_parent,ds_child,coeffraf,locind_child_left) 2334 real :: s_parent,s_child,ds_parent,ds_child 2335 integer :: coeffraf,locind_child_left 2336 2337 coeffraf = nint(ds_parent/ds_child) 2338 locind_child_left = 1 + agrif_int((s_parent-s_child)/ds_child) 2339 2340 End Subroutine Agrif_Compute_nbdim_update 2341 2342 #if defined AGRIF_MPI 2343 Subroutine Agrif_Find_list_update(list_update,pttab,petab, 2344 & pttab_Child,pttab_Parent,nbdim, 2345 & find_list_update,tab4t,tab5t,memberinall,memberinall2) 2346 TYPE(Agrif_List_Interp_Loc), Pointer :: list_update 2347 INTEGER :: nbdim 2348 INTEGER,DIMENSION(nbdim) :: pttab,petab,pttab_Child,pttab_Parent 2349 LOGICAL :: find_list_update 2350 Type(Agrif_List_Interp_loc), Pointer :: parcours 2351 INTEGER :: i 2352 C 2353 INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,4) :: tab4t, tab5t 2354 LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: memberinall,memberinall2 2355 2356 find_list_update = .FALSE. 2357 2358 parcours => list_update 2359 2360 Find_loop : Do While (associated(parcours)) 2361 Do i=1,nbdim 2362 IF ((pttab(i) /= parcours%interp_loc%pttab(i)).OR. 2363 & (petab(i) /= parcours%interp_loc%petab(i)).OR. 2364 & (pttab_child(i) /= parcours%interp_loc%pttab_child(i)).OR. 2365 & (pttab_parent(i) /= parcours%interp_loc%pttab_parent(i))) 2366 & THEN 2367 parcours=>parcours%suiv 2368 Cycle Find_loop 2369 ENDIF 2370 EndDo 2371 2372 tab4t = parcours%interp_loc%tab4t(1:nbdim,0:Agrif_Nbprocs-1,1:4) 2373 memberinall = parcours%interp_loc%memberinall(0:Agrif_Nbprocs-1) 2374 2375 tab5t = parcours%interp_loc%tab5t(1:nbdim,0:Agrif_Nbprocs-1,1:4) 2376 memberinall2 = 2377 & parcours%interp_loc%memberinall2(0:Agrif_Nbprocs-1) 2378 2379 find_list_update = .TRUE. 2380 Exit Find_loop 2381 End Do Find_loop 2382 2383 End Subroutine Agrif_Find_list_update 2384 2385 Subroutine Agrif_AddTo_list_update(list_update,pttab,petab, 2386 & pttab_Child,pttab_Parent,nbdim 2387 & ,tab4t,tab5t,memberinall,memberinall2) 2388 2389 TYPE(Agrif_List_Interp_Loc), Pointer :: list_update 2390 INTEGER :: nbdim 2391 INTEGER,DIMENSION(nbdim) :: pttab,petab,pttab_Child,pttab_Parent 2392 INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,4) :: tab4t, tab5t 2393 LOGICAL,DIMENSION(0:Agrif_Nbprocs-1) :: memberinall, memberinall2 2394 2395 Type(Agrif_List_Interp_loc), Pointer :: parcours 2396 2397 Allocate(parcours) 2398 Allocate(parcours%interp_loc) 2399 2400 parcours%interp_loc%pttab(1:nbdim) = pttab(1:nbdim) 2401 parcours%interp_loc%petab(1:nbdim) = petab(1:nbdim) 2402 parcours%interp_loc%pttab_child(1:nbdim) = pttab_child(1:nbdim) 2403 parcours%interp_loc%pttab_parent(1:nbdim) = pttab_parent(1:nbdim) 2404 Allocate(parcours%interp_loc%tab4t(nbdim,0:Agrif_Nbprocs-1,4)) 2405 Allocate(parcours%interp_loc%memberinall(0:Agrif_Nbprocs-1)) 2406 2407 Allocate(parcours%interp_loc%tab5t(nbdim,0:Agrif_Nbprocs-1,4)) 2408 Allocate(parcours%interp_loc%memberinall2(0:Agrif_Nbprocs-1)) 2409 2410 parcours%interp_loc%tab4t=tab4t 2411 parcours%interp_loc%memberinall=memberinall 2412 2413 parcours%interp_loc%tab5t=tab5t 2414 parcours%interp_loc%memberinall2=memberinall2 2415 2416 parcours%suiv => list_update 2417 2418 list_update => parcours 2419 2420 End Subroutine Agrif_Addto_list_update 2421 #endif 2422 2240 2423 End Module Agrif_Update 2241 2424 2242 2243 2244 2425 C ************************************************************************** 2426 CCC Subroutine Agrif_Update_1D_Recursive 2427 C ************************************************************************** 2428 C 2429 Subroutine Agrif_Update_1D_recursive(TypeUpdate,tempP,tempC, 2430 & indmin,indmax, 2431 & pttab_child,petab_child, 2432 & s_child,s_parent, 2433 & ds_child,ds_parent,nbdim) 2434 C 2435 CCC Description: 2436 CCC Subroutine to update a 1D grid variable on the parent grid. 2437 C 2438 CC Method: 2439 C 2440 C Declarations: 2441 C 2442 2443 C 2444 C Arguments 2445 USE Agrif_Update 2446 INTEGER :: nbdim 2447 INTEGER, DIMENSION(nbdim) :: TypeUpdate ! TYPE of update (copy or average) 2448 INTEGER, DIMENSION(nbdim) :: indmin,indmax 2449 INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child 2450 REAL, DIMENSION(nbdim) :: s_child,s_parent 2451 REAL, DIMENSION(nbdim) :: ds_child,ds_parent 2452 REAL, DIMENSION(indmin(nbdim):indmax(nbdim)) :: tempP 2453 REAL, DIMENSION(pttab_child(nbdim):petab_child(nbdim)) :: tempC 2454 INTEGER :: coeffraf,locind_child_left 2455 C 2456 C 2457 Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim), 2458 & ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left) 2459 2460 Call Agrif_UpdateBase(TypeUpdate(1), 2461 & tempP(indmin(nbdim):indmax(nbdim)), 2462 & tempC(pttab_child(nbdim):petab_child(nbdim)), 2463 & indmin(nbdim),indmax(nbdim), 2464 & pttab_child(nbdim),petab_child(nbdim), 2465 & s_parent(nbdim),s_child(nbdim), 2466 & ds_parent(nbdim),ds_child(nbdim), 2467 & coeffraf,locind_child_left) 2468 C 2469 Return 2470 C 2471 C 2472 End Subroutine Agrif_Update_1D_recursive -
trunk/AGRIF/AGRIF_FILES/modupdatebasic.F
r447 r662 48 48 C ************************************************************************** 49 49 C 50 Subroutine copy1d(x,y,np,nc,50 Subroutine agrif_copy1d(x,y,np,nc, 51 51 & s_parent,s_child,ds_parent,ds_child) 52 52 C … … 99 99 C 100 100 C 101 End Subroutine copy1d101 End Subroutine agrif_copy1d 102 102 C 103 103 C … … 147 147 148 148 IF ( mod(coeffraf,2) == 0 ) diffmod = 1 149 150 locind_child_left = 1 + agrif_int((xpos - s_child)/ds_child) 149 151 150 152 do i = 1,np 151 153 C 152 locind_child_left = 1 + agrif_int((xpos - s_child)/ds_child) 153 C 154 if ((locind_child_left-1 < 1)155 & .OR. (locind_child_left+1 > nc)) then156 C 157 x(i) = y(locind_child_left)158 C 159 else154 155 C 156 c if ((locind_child_left-1 < 1) 157 c & .OR. (locind_child_left+1 > nc)) then 158 C 159 c x(i) = y(locind_child_left) 160 C 161 c else 160 162 nbnonnuls = 0 161 163 Do ii = -coeffraf/2+locind_child_left+diffmod, … … 181 183 ENDIF 182 184 C 183 endif 184 C 185 xpos = xpos + ds_parent 185 c endif 186 C 187 c xpos = xpos + ds_parent 188 locind_child_left = locind_child_left + coeffraf 186 189 C 187 190 enddo … … 199 202 C 200 203 Subroutine full_weighting1D(x,y,np,nc, 201 & s_parent,s_child,ds_parent,ds_child) 204 & s_parent,s_child,ds_parent,ds_child, 205 & coeffraf,locind_child_left) 202 206 C 203 207 CCC Description: … … 214 218 C Local variables 215 219 INTEGER :: i,locind_child_left,coeffraf 216 REAL :: xpos 217 C 218 C 219 coeffraf = nint(ds_parent/ds_child) 220 REAL :: xpos,sumweight,weight 221 INTEGER :: ii,diffmod 222 REAL :: xposfin 223 INTEGER :: it1,it2 224 INTEGER :: i1,i2 225 REAL :: invsumweight 226 REAL :: weights(-(coeffraf-1):coeffraf-1) 227 228 C 220 229 C 221 230 if (coeffraf == 1) then 222 C223 locind_child_left = 1 + nint((s_parent - s_child)/ds_child)224 231 C 225 232 x(1:np) = y(locind_child_left:locind_child_left+np-1) … … 229 236 endif 230 237 C 231 IF (coeffraf .NE. 3) THEN232 print *,'FULL WEIGHTING NOT READY FOR COEFFRAF = 3'233 STOP234 ENDIF235 238 xpos = s_parent 236 C 239 240 x = 0. 241 242 xposfin = s_child + ds_child * (locind_child_left - 1) 243 IF (abs(xposfin - xpos).LT.0.001) THEN 244 diffmod = 0 245 ELSE 246 diffmod = 1 247 ENDIF 248 C 249 250 it1 = -(coeffraf-1) 251 i1 = -(coeffraf-1)+locind_child_left+diffmod 252 i2 = 2*coeffraf - 2 253 254 invsumweight=1./coeffraf**2 255 do i=-(coeffraf-1),0 256 weights(i) = invsumweight*(coeffraf + i) 257 enddo 258 do i=1,coeffraf-1 259 weights(i) = invsumweight*(coeffraf - i) 260 enddo 261 262 sumweight = 0 237 263 do i = 1,np 238 264 C 239 locind_child_left = 1 + nint((xpos - s_child)/ds_child) 240 C 241 if ((locind_child_left-1 < 1) 242 & .OR. (locind_child_left+1 > nc)) then 243 C Agrif_UseSpecialValueInUpdate = .TRUE. 244 x(i) = y(locind_child_left) 245 C 246 else 247 C 248 x(i) = (y(locind_child_left-1)+2.*y(locind_child_left)+ 249 & y(locind_child_left+1))/4. 250 C 251 endif 252 C 253 xpos = xpos + ds_parent 254 C 255 enddo 265 it2 = it1 266 Do ii = i1,i1+i2 267 C 268 IF (Agrif_UseSpecialValueInUpdate) THEN 269 IF (y(ii) .NE. Agrif_SpecialValueFineGrid) THEN 270 x(i) = x(i) + weights(it2)*y(ii) 271 sumweight = sumweight+weights(it2) 272 ENDIF 273 ELSE 274 x(i) = x(i) + weights(it2)*y(ii) 275 ENDIF 276 277 it2 = it2+1 278 End Do 279 280 IF (Agrif_UseSpecialValueInUpdate) THEN 281 IF (sumweight .NE. 0.) THEN 282 x(i) = x(i)/sumweight 283 sumweight = 0 284 ELSE 285 x(i) = Agrif_SpecialValueFineGrid 286 ENDIF 287 ENDIF 288 289 i1 = i1 + coeffraf 290 C 291 enddo 256 292 C 257 293 Return 258 294 C 259 295 C 260 End Subroutine full_weighting1D 261 C 262 C 296 End Subroutine full_weighting1D 297 263 298 C 264 299 End module AGRIF_updatebasic
Note: See TracChangeset
for help on using the changeset viewer.