Changeset 662 for trunk/AGRIF/AGRIF_FILES/modupdate.F
- Timestamp:
- 2007-05-25T17:58:52+02:00 (17 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
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
Note: See TracChangeset
for help on using the changeset viewer.