Changeset 13027
- Timestamp:
- 2020-06-03T16:36:09+02:00 (3 years ago)
- Location:
- vendors/AGRIF/dev_r12970_AGRIF_CMEMS
- Files:
-
- 1 added
- 32 edited
Legend:
- Unmodified
- Added
- Removed
-
vendors/AGRIF/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modarrays.F90
r5656 r13027 55 55 proc_id, & 56 56 coords, & 57 lb_tab_true, ub_tab_true, memberin ) 57 lb_tab_true, ub_tab_true, memberin, & 58 indminglob3,indmaxglob3,check_perio) 58 59 !--------------------------------------------------------------------------------------------------- 59 60 integer, intent(in) :: nbdim !< Number of dimensions … … 61 62 integer, dimension(nbdim), intent(in) :: ub_var !< Local upper boundary on the current processor 62 63 integer, dimension(nbdim), intent(in) :: lb_tab !< Global lower boundary of the variable 64 integer, dimension(nbdim),OPTIONAL :: indminglob3,indmaxglob3 !< True bounds for MPI USE 63 65 integer, dimension(nbdim), intent(in) :: ub_tab !< Global upper boundary of the variable 64 66 integer, intent(in) :: proc_id !< Current processor … … 67 69 integer, dimension(nbdim), intent(out) :: ub_tab_true !< Global value of ub_var on the current processor 68 70 logical, intent(out) :: memberin 71 logical,optional, intent(in) :: check_perio !< check for periodicity 72 logical :: check_perio_local 69 73 ! 70 74 integer :: i, coord_i 71 75 integer :: lb_glob_index, ub_glob_index ! Lower and upper global indices 76 77 if (present(check_perio)) then 78 check_perio_local=check_perio 79 else 80 check_perio_local = .FALSE. 81 endif 72 82 ! 73 83 do i = 1, nbdim … … 78 88 call Agrif_InvLoc( lb_var(i), proc_id, coord_i, lb_glob_index ) 79 89 call Agrif_InvLoc( ub_var(i), proc_id, coord_i, ub_glob_index ) 90 if (agrif_debug_interp .or. agrif_debug_update) then 91 print *,'direction ',i,' lblogb ubglob = ',lb_glob_index,ub_glob_index 92 endif 93 if (check_perio_local .AND. agrif_curgrid%periodicity(i)) then 94 if (lb_tab(i)>=lb_glob_index) then 95 else if (lb_tab(i)<ub_glob_index-agrif_curgrid%periodicity_decal(i)) then 96 lb_glob_index = lb_glob_index - agrif_curgrid%periodicity_decal(i) 97 ub_glob_index = ub_glob_index - agrif_curgrid%periodicity_decal(i) 98 endif 99 endif 100 101 if (present(indminglob3)) then 102 indminglob3(i)=lb_glob_index 103 indmaxglob3(i)=ub_glob_index 104 endif 80 105 #else 81 106 lb_glob_index = lb_var(i) 107 if (check_perio_local .AND. agrif_curgrid%periodicity(i)) then 108 lb_glob_index = lb_tab(i) 109 endif 82 110 ub_glob_index = ub_var(i) 83 111 #endif 84 112 lb_tab_true(i) = max(lb_tab(i), lb_glob_index) 85 113 ub_tab_true(i) = min(ub_tab(i), ub_glob_index) 114 if (agrif_debug_interp .or. agrif_debug_update) then 115 print *,'childbounds = ',i,lb_tab(i),lb_glob_index,lb_tab_true(i), & 116 ub_tab(i),ub_glob_index,ub_tab_true(i) 117 endif 86 118 enddo 87 119 ! … … 93 125 endif 94 126 enddo 127 if (agrif_debug_interp) then 128 print *,'memberin = ',memberin 129 endif 95 130 !--------------------------------------------------------------------------------------------------- 96 131 end subroutine Agrif_Childbounds … … 123 158 ! 124 159 iminmaxg(1:nbdim,2) = - iminmaxg(1:nbdim,2) 125 call MPI_ALLREDUCE(iminmaxg, lubglob, 2*nbdim, MPI_INTEGER, MPI_MIN, Agrif_mpi_comm, code) 160 call MPI_ALLREDUCE(iminmaxg, lubglob, 2*nbdim, MPI_INTEGER, MPI_MIN, & 161 Agrif_mpi_comm, code) 126 162 lubglob(1:nbdim,2) = - lubglob(1:nbdim,2) 127 163 #endif … … 659 695 case('x') 660 696 ! 661 lb_child(n) = root_var %point(n)662 lb_parent(n) = root_var %point(n)697 lb_child(n) = child%point(n) 698 lb_parent(n) = child%parent_var%point(n) 663 699 nb_child(n) = Agrif_Child_Gr % nb(1) 664 700 s_child(n) = Agrif_Child_Gr % Agrif_x(1) … … 666 702 ds_child(n) = Agrif_Child_Gr % Agrif_dx(1) 667 703 ds_parent(n) = Agrif_Parent_Gr % Agrif_dx(1) 704 ! Take into account potential difference of first points 705 s_parent(n) = s_parent(n) + (lb_parent(n)-lb_child(n))*ds_parent(n) 668 706 ! 669 707 if ( root_var % posvar(n) == 1 ) then … … 677 715 case('y') 678 716 ! 679 lb_child(n) = root_var %point(n)680 lb_parent(n) = root_var %point(n)717 lb_child(n) = child%point(n) 718 lb_parent(n) = child%parent_var%point(n) 681 719 nb_child(n) = Agrif_Child_Gr % nb(2) 682 720 s_child(n) = Agrif_Child_Gr % Agrif_x(2) … … 684 722 ds_child(n) = Agrif_Child_Gr % Agrif_dx(2) 685 723 ds_parent(n) = Agrif_Parent_Gr % Agrif_dx(2) 724 ! Take into account potential difference of first points 725 s_parent(n) = s_parent(n) + (lb_parent(n)-lb_child(n))*ds_parent(n) 686 726 ! 687 727 if (root_var % posvar(n)==1) then … … 695 735 case('z') 696 736 ! 697 lb_child(n) = root_var %point(n)698 lb_parent(n) = root_var %point(n)737 lb_child(n) = child%point(n) 738 lb_parent(n) = child%parent_var%point(n) 699 739 nb_child(n) = Agrif_Child_Gr % nb(3) 700 740 s_child(n) = Agrif_Child_Gr % Agrif_x(3) … … 702 742 ds_child(n) = Agrif_Child_Gr % Agrif_dx(3) 703 743 ds_parent(n) = Agrif_Parent_Gr % Agrif_dx(3) 744 ! Take into account potential difference of first points 745 s_parent(n) = s_parent(n) + (lb_parent(n)-lb_child(n))*ds_parent(n) 704 746 ! 705 747 if (root_var % posvar(n)==1) then … … 781 823 !--------------------------------------------------------------------------------------------------- 782 824 subroutine Agrif_GlobalToLocalBounds ( locbounds, lb_var, ub_var, lb_glob, ub_glob, & 783 coords, nbdim, rank, member )825 coords, nbdim, rank, member,check_perio ) 784 826 !--------------------------------------------------------------------------------------------------- 785 827 integer, dimension(nbdim,2,2), intent(out) :: locbounds !< Local values of \b lb_glob and \b ub_glob … … 792 834 integer, intent(in) :: rank !< Rank of the processor 793 835 logical, intent(out) :: member 794 ! 795 integer :: i, i1, k 836 logical,optional, intent(in) :: check_perio !< check for periodicity 837 logical :: check_perio_local 838 ! 839 integer :: i, i1, k, idecal 796 840 integer :: nbloc(nbdim) 841 842 if (present(check_perio)) then 843 check_perio_local=check_perio 844 else 845 check_perio_local = .FALSE. 846 endif 847 ! 848 797 849 ! 798 850 locbounds(:,1,:) = HUGE(1) … … 803 855 do i = 1,nbdim 804 856 ! 857 if (coords(i) == 0) then 858 nbloc(i) = 1 859 locbounds(i,1,1) = lb_glob(i) 860 locbounds(i,2,1) = ub_glob(i) 861 locbounds(i,1,2) = lb_glob(i) 862 locbounds(i,2,2) = ub_glob(i) 863 else 805 864 call Agrif_InvLoc(lb_var(i), rank, coords(i), i1) 865 if ((i1>ub_glob(i)).AND.check_perio_local) then 866 idecal = agrif_curgrid%periodicity_decal(i) 867 else 868 idecal = 0 869 endif 806 870 ! 807 871 do k = lb_glob(i)+lb_var(i)-i1,ub_glob(i)+lb_var(i)-i1 808 872 ! 809 if ( (k >= lb_var(i)) .AND. (k <= ub_var(i)) ) then 873 if ( (k + idecal >= lb_var(i)) .AND. (k + idecal <= ub_var(i)) ) then 874 ! if ((k<=ub_var(i)).AND.((k>=lb_var(i).OR.check_perio_local))) then 810 875 nbloc(i) = 1 811 876 locbounds(i,1,1) = min(locbounds(i,1,1),k-lb_var(i)+i1) 812 877 locbounds(i,2,1) = max(locbounds(i,2,1),k-lb_var(i)+i1) 813 878 814 locbounds(i,1,2) = min(locbounds(i,1,2),k) 815 locbounds(i,2,2) = max(locbounds(i,2,2),k) 816 endif 817 enddo 879 locbounds(i,1,2) = min(locbounds(i,1,2),k + idecal) 880 locbounds(i,2,2) = max(locbounds(i,2,2),k + idecal) 881 endif 882 enddo 883 endif 818 884 enddo 819 885 -
vendors/AGRIF/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modbc.F90
r5656 r13027 73 73 Agrif_Parent_Gr => Agrif_Curgrid % parent 74 74 ! 75 loctab_child( :) = 075 loctab_child(1:nbdim) = 0 76 76 posvartab_child(1:nbdim) = root_var % posvar(1:nbdim) 77 77 ! -
vendors/AGRIF/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modbcfunction.F90
r5656 r13027 53 53 !> To set the TYPE of the variable 54 54 !--------------------------------------------------------------------------------------------------- 55 subroutine Agrif_Set_parent_int( tabvarsindic,value)56 !--------------------------------------------------------------------------------------------------- 57 integer, intent(in) :: tabvarsindic!< indice of the variable in tabvars55 subroutine Agrif_Set_parent_int(integer_variable,value) 56 !--------------------------------------------------------------------------------------------------- 57 integer, intent(in) :: integer_variable !< indice of the variable in tabvars 58 58 integer, intent(in) :: value !< input value 59 59 ! 60 Agrif_Curgrid % parent % tabvars_i(tabvarsindic) % iarray0 = value 60 61 integer :: i 62 logical :: i_found 63 64 i_found = .FALSE. 65 66 do i=1,Agrif_NbVariables(4) 67 if (LOC(integer_variable) == LOC(agrif_curgrid%tabvars_i(i)%iarray0)) then 68 agrif_curgrid%tabvars_i(i)%parent_var%iarray0 = value 69 i_found = .TRUE. 70 EXIT 71 endif 72 enddo 73 74 if (.NOT.i_found) STOP 'Agrif_Set_Integer : Variable not found' 75 61 76 !--------------------------------------------------------------------------------------------------- 62 77 end subroutine Agrif_Set_parent_int … … 66 81 ! subroutine Agrif_Set_parent_real4 67 82 !--------------------------------------------------------------------------------------------------- 68 !> To set the TYPE of the variable 69 !--------------------------------------------------------------------------------------------------- 70 subroutine Agrif_Set_parent_real4 ( tabvarsindic, value ) 71 !--------------------------------------------------------------------------------------------------- 72 integer, intent(in) :: tabvarsindic !< indice of the variable in tabvars 73 real(kind=4),intent(in) :: value !< input value 74 ! 75 Agrif_Curgrid % parent % tabvars_r(tabvarsindic) % array0 = value 76 Agrif_Curgrid % parent % tabvars_r(tabvarsindic) % sarray0 = value 83 !> To set the parent value of a real variable 84 !--------------------------------------------------------------------------------------------------- 85 subroutine Agrif_Set_parent_real4 ( real_variable, value ) 86 !--------------------------------------------------------------------------------------------------- 87 real(kind=4), intent(in) :: real_variable !< input variable 88 real(kind=4),intent(in) :: value !< input value for the parent grid 89 90 integer :: i 91 logical :: i_found 92 93 i_found = .FALSE. 94 95 do i=1,Agrif_NbVariables(2) 96 if (LOC(real_variable) == LOC(agrif_curgrid%tabvars_r(i)%array0)) then 97 agrif_curgrid%tabvars_r(i)%parent_var%array0 = value 98 agrif_curgrid%tabvars_r(i)%parent_var%sarray0 = value 99 i_found = .TRUE. 100 EXIT 101 endif 102 enddo 103 104 IF (.NOT.i_found) THEN 105 do i=1,Agrif_NbVariables(2) 106 if (LOC(real_variable) == LOC(agrif_curgrid%tabvars_r(i)%sarray0)) then 107 agrif_curgrid%tabvars_r(i)%parent_var%array0 = value 108 agrif_curgrid%tabvars_r(i)%parent_var%sarray0 = value 109 i_found = .TRUE. 110 EXIT 111 endif 112 enddo 113 ENDIF 114 115 if (.NOT.i_found) STOP 'Agrif_Set_parent_real4 : Variable not found' 116 77 117 !--------------------------------------------------------------------------------------------------- 78 118 end subroutine Agrif_Set_parent_real4 … … 82 122 ! subroutine Agrif_Set_parent_real8 83 123 !--------------------------------------------------------------------------------------------------- 84 !> To set the TYPE of the variable 85 !--------------------------------------------------------------------------------------------------- 86 subroutine Agrif_Set_parent_real8 ( tabvarsindic, value ) 87 !--------------------------------------------------------------------------------------------------- 88 integer, intent(in) :: tabvarsindic !< indice of the variable in tabvars 89 real(kind=8),intent(in) :: value !< input value 90 ! 91 Agrif_Curgrid % parent % tabvars_r(tabvarsindic) % darray0 = value 124 !> To set the parent value of a real variable 125 !--------------------------------------------------------------------------------------------------- 126 subroutine Agrif_Set_parent_real8 ( real_variable, value ) 127 !--------------------------------------------------------------------------------------------------- 128 real(kind=8), intent(in) :: real_variable !< input variable 129 real(kind=8),intent(in) :: value !< input value for the parent grid 130 131 integer :: i 132 logical :: i_found 133 134 i_found = .FALSE. 135 136 do i=1,Agrif_NbVariables(2) 137 if (LOC(real_variable) == LOC(agrif_curgrid%tabvars_r(i)%array0)) then 138 agrif_curgrid%tabvars_r(i)%parent_var%darray0 = value 139 agrif_curgrid%tabvars_r(i)%parent_var%array0 = value 140 i_found = .TRUE. 141 EXIT 142 endif 143 enddo 144 145 IF (.NOT.i_found) THEN 146 do i=1,Agrif_NbVariables(2) 147 if (LOC(real_variable) == LOC(agrif_curgrid%tabvars_r(i)%darray0)) then 148 agrif_curgrid%tabvars_r(i)%parent_var%darray0 = value 149 agrif_curgrid%tabvars_r(i)%parent_var%array0 = value 150 i_found = .TRUE. 151 EXIT 152 endif 153 enddo 154 ENDIF 155 156 if (.NOT.i_found) STOP 'Agrif_Set_parent_real8 : Variable not found' 157 92 158 !--------------------------------------------------------------------------------------------------- 93 159 end subroutine Agrif_Set_parent_real8 … … 106 172 type(Agrif_Variable), pointer :: var 107 173 ! 108 indic = Agrif_Curgrid % tabvars_i(tabvarsindic) % iarray0 109 ! 110 if (indic <= 0) then 111 var => Agrif_Search_Variable(Agrif_Curgrid,-indic) 112 else 113 print*,"Agrif_Set_bc : warning indic >= 0 !!!" 114 var => Agrif_Curgrid % tabvars(indic) 115 endif 116 174 var => Agrif_Search_Variable(Agrif_Curgrid,tabvarsindic) 117 175 if (.not.associated(var)) return ! Grand mother grid case 118 176 ! … … 145 203 type(Agrif_Variable), pointer :: var 146 204 ! 147 indic = Agrif_Curgrid % tabvars_i(tabvarsindic) % iarray0 148 ! 149 if (indic <= 0) then 150 var => Agrif_Search_Variable(Agrif_Mygrid,-indic) 151 else 152 print*,"Agrif_Set_interp : warning indic >= 0 !!!" 153 var => Agrif_Mygrid % tabvars(indic) 154 endif 205 var => Agrif_Search_Variable(Agrif_Curgrid,tabvarsindic) 206 if (.not.associated(var)) return ! Grand mother grid case 155 207 ! 156 208 var % type_interp = Agrif_Constant … … 178 230 TYPE(Agrif_Variable), pointer :: var 179 231 ! 180 indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0 181 ! 182 if (indic <= 0) then 183 var => Agrif_Search_Variable(Agrif_Mygrid,-indic) 184 else 185 print*,"Agrif_Set_bcinterp : warning indic >= 0 !!!" 186 var => Agrif_Mygrid % tabvars(indic) 187 endif 232 var => Agrif_Search_Variable(Agrif_Curgrid,tabvarsindic) 188 233 ! 189 234 var % type_interp_bc = Agrif_Constant … … 214 259 type(Agrif_Variable), pointer :: root_var 215 260 ! 216 indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0 217 ! 218 if (indic <= 0) then 219 root_var => Agrif_Search_Variable(Agrif_Mygrid,-indic) 220 else 221 print*,"Agrif_Set_UpdateType : warning indic >= 0 !!!" 222 root_var => Agrif_Mygrid % tabvars(indic) 223 endif 261 262 root_var => Agrif_Search_Variable(Agrif_Mygrid,tabvarsindic) 263 224 264 ! 225 265 root_var % type_update = Agrif_Update_Copy … … 243 283 INTEGER :: indic ! indice of the variable in tabvars 244 284 ! 285 print *,'CURRENTLY BROKEN' 286 STOP 287 245 288 indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0 246 289 ! … … 283 326 type(Agrif_Variable), pointer :: child_var 284 327 type(Agrif_Variable), pointer :: child_tmp ! Temporary variable on the child grid 328 integer :: i 329 integer,dimension(7) :: lb, ub 285 330 ! 286 331 if ( Agrif_Curgrid%level <= 0 ) return 287 332 ! 288 indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0289 333 ! 290 334 if ( present(calledweight) ) then … … 296 340 endif 297 341 ! 298 if (indic <= 0) then 299 child_var => Agrif_Search_Variable(Agrif_Curgrid,-indic) 342 child_var => Agrif_Search_Variable(Agrif_Curgrid,tabvarsindic) 300 343 parent_var => child_var % parent_var 301 344 root_var => child_var % root_var 302 else303 print*,"Agrif_Bc_variable : warning indic >= 0 !!!"304 child_var => Agrif_Curgrid % tabvars(indic)305 parent_var => Agrif_Curgrid % parent % tabvars(indic)306 root_var => Agrif_Mygrid % tabvars(indic)307 endif308 345 ! 309 346 nbdim = root_var % nbdim 310 347 ! 348 do i=1,nbdim 349 if (root_var%coords(i) == 0) then 350 lb(i) = parent_var%lb(i) 351 ub(i) = parent_var%ub(i) 352 else 353 lb(i) = child_var%lb(i) 354 ub(i) = child_var%ub(i) 355 endif 356 enddo 357 311 358 select case( nbdim ) 312 359 case(1) 313 allocate(parray1( child_var%lb(1):child_var%ub(1)))360 allocate(parray1(lb(1):ub(1))) 314 361 case(2) 315 allocate(parray2( child_var%lb(1):child_var%ub(1), &316 child_var%lb(2):child_var%ub(2) ))362 allocate(parray2(lb(1):ub(1), & 363 lb(2):ub(2) )) 317 364 case(3) 318 allocate(parray3( child_var%lb(1):child_var%ub(1), &319 child_var%lb(2):child_var%ub(2), &320 child_var%lb(3):child_var%ub(3) ))365 allocate(parray3(lb(1):ub(1), & 366 lb(2):ub(2), & 367 lb(3):ub(3) )) 321 368 case(4) 322 allocate(parray4( child_var%lb(1):child_var%ub(1), &323 child_var%lb(2):child_var%ub(2), &324 child_var%lb(3):child_var%ub(3), &325 child_var%lb(4):child_var%ub(4) ))369 allocate(parray4(lb(1):ub(1), & 370 lb(2):ub(2), & 371 lb(3):ub(3), & 372 lb(4):ub(4) )) 326 373 case(5) 327 allocate(parray5( child_var%lb(1):child_var%ub(1), &328 child_var%lb(2):child_var%ub(2), &329 child_var%lb(3):child_var%ub(3), &330 child_var%lb(4):child_var%ub(4), &331 child_var%lb(5):child_var%ub(5) ))374 allocate(parray5(lb(1):ub(1), & 375 lb(2):ub(2), & 376 lb(3):ub(3), & 377 lb(4):ub(4), & 378 lb(5):ub(5) )) 332 379 case(6) 333 allocate(parray6( child_var%lb(1):child_var%ub(1), &334 child_var%lb(2):child_var%ub(2), &335 child_var%lb(3):child_var%ub(3), &336 child_var%lb(4):child_var%ub(4), &337 child_var%lb(5):child_var%ub(5), &338 child_var%lb(6):child_var%ub(6) ))380 allocate(parray6(lb(1):ub(1), & 381 lb(2):ub(2), & 382 lb(3):ub(3), & 383 lb(4):ub(4), & 384 lb(5):ub(5), & 385 lb(6):ub(6) )) 339 386 end select 340 387 ! … … 343 390 ! 344 391 child_tmp % root_var => root_var 392 child_tmp % parent_var => parent_var 345 393 child_tmp % oldvalues2D => child_var % oldvalues2D 346 394 ! … … 400 448 type(Agrif_Variable), pointer :: child_tmp ! Temporary variable on the child grid 401 449 ! 450 402 451 if ( Agrif_Curgrid%level <= 0 ) return 403 452 ! 404 indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0 405 ! 406 if (indic <= 0) then 407 child_var => Agrif_Search_Variable(Agrif_Curgrid,-indic) 453 454 child_var => Agrif_Search_Variable(Agrif_Curgrid,tabvarsindic) 408 455 parent_var => child_var % parent_var 409 456 root_var => child_var % root_var 410 else 411 print*,"Agrif_Interp_variable : warning indic >= 0 !!!" 412 child_var => Agrif_Curgrid % tabvars(indic) 413 parent_var => Agrif_Curgrid % parent % tabvars(indic) 414 root_var => Agrif_Mygrid % tabvars(indic) 415 endif 457 416 458 ! 417 459 nbdim = root_var % nbdim … … 421 463 ! 422 464 child_tmp % root_var => root_var 465 child_tmp % parent_var => parent_var 423 466 child_tmp % nbdim = root_var % nbdim 424 467 child_tmp % point = child_var % point … … 486 529 if (agrif_curgrid%grand_mother_grid) return 487 530 ! 488 indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0 489 ! 490 if (indic <= 0) then 491 child_var => Agrif_Search_Variable(Agrif_Curgrid, -indic) 531 532 child_var => Agrif_Search_Variable(Agrif_Curgrid, tabvarsindic) 492 533 parent_var => child_var % parent_var 493 534 494 535 if (.not.associated(parent_var)) then 495 536 ! can occur during the first update of Agrif_Coarsegrid (if any) 496 parent_var => Agrif_Search_Variable(Agrif_Curgrid % parent, -indic)537 parent_var => Agrif_Search_Variable(Agrif_Curgrid % parent, tabvarsindic) 497 538 child_var % parent_var => parent_var 498 539 endif 499 540 500 541 root_var => child_var % root_var 501 else 502 print*,"Agrif_Update_Variable : warning indic >= 0 !!!" 503 root_var => Agrif_Mygrid % tabvars(indic) 504 child_var => Agrif_Curgrid % tabvars(indic) 505 parent_var => Agrif_Curgrid % parent % tabvars(indic) 506 endif 542 507 543 ! 508 544 nbdim = root_var % nbdim … … 551 587 integer :: nbdim 552 588 ! 589 print *,'CURRENTLY BROKEN' 590 STOP 553 591 root_var => Agrif_Mygrid % tabvars(tabvarsindic0) 554 592 save_var => Agrif_Curgrid % tabvars(tabvarsindic0) … … 575 613 integer :: indic 576 614 ! 615 print *,'CURRENTLY BROKEN' 616 STOP 577 617 indic = tabvarsindic 578 618 if (tabvarsindic >= 0) then … … 612 652 integer :: indic 613 653 ! 654 print *,'CURRENTLY BROKEN' 655 STOP 656 614 657 indic = tabvarsindic 615 658 if (tabvarsindic >= 0) then … … 650 693 integer :: indic 651 694 ! 695 print *,'CURRENTLY BROKEN' 696 STOP 652 697 indic = tabvarsindic 653 698 if (tabvarsindic >= 0) then -
vendors/AGRIF/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modcurgridfunctions.F90
r5656 r13027 29 29 implicit none 30 30 ! 31 32 interface Agrif_Parent 33 module procedure Agrif_Parent_Real_4, & 34 Agrif_Parent_Real_8, & 35 Agrif_Parent_Array2_Real_8, & 36 Agrif_Parent_Integer, & 37 Agrif_Parent_Character, & 38 Agrif_Parent_Logical 39 end interface 40 interface Agrif_Child 41 module procedure Agrif_Child_Logical 42 end interface 43 31 44 contains 32 45 ! … … 657 670 end subroutine Agrif_Set_coeffreft_z 658 671 !=================================================================================================== 672 ! subroutine Agrif_Set_coeffreft 673 !--------------------------------------------------------------------------------------------------- 674 subroutine Agrif_Set_coeffreft ( coeffref ) 675 !--------------------------------------------------------------------------------------------------- 676 integer, intent(in) :: coeffref 677 integer :: i 678 679 if (coeffref < 0) then 680 write(*,*)'Coefficient of time raffinement should be positive' 681 stop 682 else 683 do i=1,Agrif_Probdim 684 Agrif_coeffreft(i) = coeffref 685 Agrif_Curgrid % timeref(i) = coeffref 686 enddo 687 endif 688 !--------------------------------------------------------------------------------------------------- 689 end subroutine Agrif_Set_coeffreft 690 !=================================================================================================== 659 691 ! 660 692 !=================================================================================================== … … 738 770 end function Agrif_Level 739 771 !=================================================================================================== 772 !=================================================================================================== 773 ! subroutine Agrif_set_periodicity 774 !--------------------------------------------------------------------------------------------------- 775 776 subroutine Agrif_set_periodicity(i,decal) 777 !--------------------------------------------------------------------------------------------------- 778 integer :: i, decal 779 780 Agrif_curgrid%periodicity(i)=.TRUE. 781 Agrif_curgrid%periodicity_decal(i)=decal 782 783 !--------------------------------------------------------------------------------------------------- 784 end subroutine Agrif_set_periodicity 740 785 ! 741 786 !=================================================================================================== … … 763 808 !=================================================================================================== 764 809 ! 810 811 function Agrif_Parent_Real_4(real_variable) result(real_variable_parent) 812 real(KIND=4) :: real_variable 813 real(KIND=4) :: real_variable_parent 814 815 integer :: i 816 logical :: i_found 817 818 i_found = .FALSE. 819 820 do i=1,Agrif_NbVariables(2) 821 if (LOC(real_variable) == LOC(agrif_curgrid%tabvars_r(i)%array0)) then 822 real_variable_parent = agrif_curgrid%tabvars_r(i)%parent_var%array0 823 i_found = .TRUE. 824 EXIT 825 endif 826 enddo 827 828 IF (.NOT.i_found) THEN 829 do i=1,Agrif_NbVariables(2) 830 if (LOC(real_variable) == LOC(agrif_curgrid%tabvars_r(i)%sarray0)) then 831 real_variable_parent = agrif_curgrid%tabvars_r(i)%parent_var%sarray0 832 i_found = .TRUE. 833 EXIT 834 endif 835 enddo 836 ENDIF 837 838 if (.NOT.i_found) STOP 'Agrif_Parent_Real_4 : Variable not found' 839 840 end function Agrif_Parent_Real_4 841 842 function Agrif_Parent_Real_8(real_variable) result(real_variable_parent) 843 real(KIND=8) :: real_variable 844 real(KIND=8) :: real_variable_parent 845 846 integer :: i 847 logical :: i_found 848 849 i_found = .FALSE. 850 851 do i=1,Agrif_NbVariables(2) 852 if (LOC(real_variable) == LOC(agrif_curgrid%tabvars_r(i)%array0)) then 853 real_variable_parent = agrif_curgrid%tabvars_r(i)%parent_var%array0 854 i_found = .TRUE. 855 EXIT 856 endif 857 enddo 858 859 IF (.NOT.i_found) THEN 860 do i=1,Agrif_NbVariables(2) 861 if (LOC(real_variable) == LOC(agrif_curgrid%tabvars_r(i)%darray0)) then 862 real_variable_parent = agrif_curgrid%tabvars_r(i)%parent_var%darray0 863 i_found = .TRUE. 864 EXIT 865 endif 866 enddo 867 ENDIF 868 869 if (.NOT.i_found) STOP 'Agrif_Parent_Real_8 : Variable not found' 870 871 end function Agrif_Parent_Real_8 872 873 function Agrif_Parent_Array2_Real_8(real_variable,ji,jj) result(real_variable_parent) 874 real(KIND=8), DIMENSION(:,:) :: real_variable 875 real(KIND=8) :: real_variable_parent 876 integer :: ji,jj 877 878 integer :: i 879 logical :: i_found 880 881 i_found = .FALSE. 882 883 do i=1,Agrif_NbVariables(0) 884 if (LOC(real_variable) == LOC(agrif_curgrid%tabvars(i)%array2)) then 885 real_variable_parent = agrif_curgrid%tabvars(i)%parent_var%array2(ji,jj) 886 i_found = .TRUE. 887 EXIT 888 endif 889 enddo 890 891 if (.NOT.i_found) STOP 'Agrif_Parent_Array2_Real_8 : Variable not found' 892 893 end function Agrif_Parent_Array2_Real_8 894 895 896 function Agrif_Parent_Integer(integer_variable) result(integer_variable_parent) 897 integer :: integer_variable 898 integer :: integer_variable_parent 899 900 integer :: i 901 logical :: i_found 902 903 i_found = .FALSE. 904 905 do i=1,Agrif_NbVariables(4) 906 if (LOC(integer_variable) == LOC(agrif_curgrid%tabvars_i(i)%iarray0)) then 907 integer_variable_parent = agrif_curgrid%tabvars_i(i)%parent_var%iarray0 908 i_found = .TRUE. 909 EXIT 910 endif 911 enddo 912 913 if (.NOT.i_found) STOP 'Agrif_Parent : Variable not found' 914 915 end function Agrif_Parent_Integer 916 917 function Agrif_Parent_Character(character_variable) result(character_variable_parent) 918 character(*) :: character_variable 919 character(len(character_variable)) :: character_variable_parent 920 921 integer :: i 922 logical :: i_found 923 924 i_found = .FALSE. 925 926 do i=1,Agrif_NbVariables(1) 927 if (LOC(character_variable) == LOC(agrif_curgrid%tabvars_c(i)%carray0)) then 928 character_variable_parent = agrif_curgrid%tabvars_c(i)%parent_var%carray0 929 i_found = .TRUE. 930 EXIT 931 endif 932 enddo 933 934 if (.NOT.i_found) STOP 'Agrif_Parent : Variable not found' 935 936 end function Agrif_Parent_Character 937 938 function Agrif_Parent_Logical(logical_variable) result(logical_variable_parent) 939 logical :: logical_variable 940 logical :: logical_variable_parent 941 942 integer :: i 943 logical :: i_found 944 945 i_found = .FALSE. 946 947 do i=1,Agrif_NbVariables(3) 948 if (LOC(logical_variable) == LOC(agrif_curgrid%tabvars_l(i)%larray0)) then 949 logical_variable_parent = agrif_curgrid%tabvars_l(i)%parent_var%larray0 950 i_found = .TRUE. 951 EXIT 952 endif 953 enddo 954 955 if (.NOT.i_found) STOP 'Agrif_Parent : Variable not found' 956 957 end function Agrif_Parent_Logical 958 959 function Agrif_Child_Logical(logical_variable) result(logical_variable_child) 960 logical :: logical_variable 961 logical :: logical_variable_child 962 963 integer :: i 964 logical :: i_found 965 966 i_found = .FALSE. 967 968 do i=1,Agrif_NbVariables(3) 969 if (LOC(logical_variable) == LOC(agrif_curgrid%tabvars_l(i)%larray0)) then 970 logical_variable_child = Agrif_CurChildgrid%tabvars_l(i)%larray0 971 i_found = .TRUE. 972 EXIT 973 endif 974 enddo 975 976 if (.NOT.i_found) STOP 'Agrif_Child : Variable not found' 977 978 end function Agrif_Child_Logical 979 980 function Agrif_Irhox() result(i_val) 981 integer :: i_val 982 i_val = agrif_curgrid%spaceref(1) 983 end function Agrif_Irhox 984 985 function Agrif_Irhoy() result(i_val) 986 integer :: i_val 987 i_val = agrif_curgrid%spaceref(2) 988 end function Agrif_Irhoy 989 990 function Agrif_Irhoz() result(i_val) 991 integer :: i_val 992 i_val = agrif_curgrid%spaceref(3) 993 end function Agrif_Irhoz 994 995 function Agrif_NearCommonBorderX() result(l_val) 996 logical :: l_val 997 l_val = agrif_curgrid%nearRootBorder(1) 998 end function Agrif_NearCommonBorderX 999 1000 subroutine Agrif_Set_NearCommonBorderX(l_val) 1001 logical,intent(in) :: l_val 1002 agrif_curgrid%nearRootBorder(1)=l_val 1003 end subroutine Agrif_Set_NearCommonBorderX 1004 1005 function Agrif_NearCommonBorderY() result(l_val) 1006 logical :: l_val 1007 l_val = agrif_curgrid%nearRootBorder(2) 1008 end function Agrif_NearCommonBorderY 1009 1010 subroutine Agrif_Set_NearCommonBorderY(l_val) 1011 logical,intent(in) :: l_val 1012 agrif_curgrid%nearRootBorder(2)=l_val 1013 end subroutine Agrif_Set_NearCommonBorderY 1014 1015 function Agrif_NearCommonBorderZ() result(l_val) 1016 logical :: l_val 1017 l_val = agrif_curgrid%nearRootBorder(3) 1018 end function Agrif_NearCommonBorderZ 1019 1020 subroutine Agrif_Set_NearCommonBorderZ(l_val) 1021 logical,intent(in) :: l_val 1022 agrif_curgrid%nearRootBorder(3)=l_val 1023 end subroutine Agrif_Set_NearCommonBorderZ 1024 1025 function Agrif_DistantCommonBorderX() result(l_val) 1026 logical :: l_val 1027 l_val = agrif_curgrid%DistantRootBorder(1) 1028 end function Agrif_DistantCommonBorderX 1029 1030 subroutine Agrif_Set_DistantCommonBorderX(l_val) 1031 logical,intent(in) :: l_val 1032 agrif_curgrid%DistantRootBorder(1)=l_val 1033 end subroutine Agrif_Set_DistantCommonBorderX 1034 1035 function Agrif_DistantCommonBorderY() result(l_val) 1036 logical :: l_val 1037 l_val = agrif_curgrid%DistantRootBorder(2) 1038 end function Agrif_DistantCommonBorderY 1039 1040 subroutine Agrif_Set_DistantCommonBorderY(l_val) 1041 logical,intent(in) :: l_val 1042 agrif_curgrid%DistantRootBorder(2)=l_val 1043 end subroutine Agrif_Set_DistantCommonBorderY 1044 1045 function Agrif_DistantCommonBorderZ() result(l_val) 1046 logical :: l_val 1047 l_val = agrif_curgrid%DistantRootBorder(3) 1048 end function Agrif_DistantCommonBorderZ 1049 1050 subroutine Agrif_Set_DistantCommonBorderZ(l_val) 1051 logical,intent(in) :: l_val 1052 agrif_curgrid%DistantRootBorder(3)=l_val 1053 end subroutine Agrif_Set_DistantCommonBorderZ 1054 1055 function Agrif_Ix() result(i_val) 1056 integer :: i_val 1057 i_val = agrif_curgrid%ix(1) 1058 end function Agrif_Ix 1059 1060 function Agrif_Iy() result(i_val) 1061 integer :: i_val 1062 i_val = agrif_curgrid%ix(2) 1063 end function Agrif_Iy 1064 1065 function Agrif_Iz() result(i_val) 1066 integer :: i_val 1067 i_val = agrif_curgrid%ix(3) 1068 end function Agrif_Iz 1069 1070 function Agrif_Get_grid_id() result(i_val) 1071 integer :: i_val 1072 i_val = agrif_curgrid % grid_id 1073 end function Agrif_Get_grid_id 1074 1075 function Agrif_Get_parent_id() result(i_val) 1076 integer :: i_val 1077 i_val = agrif_curgrid % parent % grid_id 1078 end function Agrif_Get_parent_id 1079 1080 function Agrif_rhox() result(r_val) 1081 real :: r_val 1082 r_val = real(agrif_curgrid%spaceref(1)) 1083 end function Agrif_rhox 1084 1085 function Agrif_rhoy() result(r_val) 1086 real :: r_val 1087 r_val = real(agrif_curgrid%spaceref(2)) 1088 end function Agrif_rhoy 1089 1090 function Agrif_rhoz() result(r_val) 1091 real :: r_val 1092 r_val = real(agrif_curgrid%spaceref(3)) 1093 end function Agrif_rhoz 1094 1095 function Agrif_Nb_Step() result(i_val) 1096 integer :: i_val 1097 i_val = agrif_curgrid%ngridstep 1098 end function Agrif_Nb_Step 1099 1100 function Agrif_Nb_Fine_Grids() result(i_val) 1101 integer :: i_val 1102 i_val = Agrif_nbfixedgrids 1103 end function Agrif_Nb_Fine_Grids 1104 1105 ! Set the name of the External mapping subroutine (if needed) 1106 subroutine Agrif_Set_ExternalMapping(external_mapping) 1107 Procedure(mapping) :: external_mapping 1108 1109 agrif_external_mapping => external_mapping 1110 1111 end subroutine Agrif_Set_ExternalMapping 1112 1113 ! Set the name of the user linear interp function (if needed) 1114 subroutine Agrif_Set_external_linear_interp(external_linear_interp) 1115 Procedure(linear_interp) :: external_linear_interp 1116 1117 agrif_external_linear_interp => external_linear_interp 1118 1119 end subroutine Agrif_Set_external_linear_interp 1120 1121 subroutine Agrif_UnSet_external_linear_interp() 1122 1123 nullify(agrif_external_linear_interp) 1124 1125 end subroutine Agrif_UnSet_external_linear_interp 1126 765 1127 end module Agrif_CurgridFunctions -
vendors/AGRIF/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modgrids.F90
r5656 r13027 47 47 real , dimension(3) :: Agrif_dx !< global space step in the x, y and z direction 48 48 real , dimension(3) :: Agrif_dt !< global time step in the x, y and z direction 49 integer, dimension(3) :: nb 49 integer, dimension(3) :: nb = 1 !< number of cells in the x, y and z direction 50 50 integer, dimension(3) :: ix !< minimal position in the x, y and z direction 51 51 integer, dimension(3) :: spaceref !< space refinement factor in the x, y and z direction … … 88 88 logical :: allocation_is_done = .false. 89 89 logical :: grand_mother_grid = .false. 90 logical,dimension(4) :: periodicity = .false. 91 integer,dimension(4) :: periodicity_decal = 0 90 92 !--------------------------------------------------------------------------------------------------- 91 93 end type Agrif_Grid … … 104 106 !> Pointer to the current grid (the link is done by using the Agrif_Instance procedure (\see module Agrif_Init)) 105 107 type(Agrif_Grid) , pointer :: Agrif_Curgrid => NULL() 108 109 !> Pointer to the current child grid (the link is done before calls to procname) 110 type(Agrif_Grid) , pointer :: Agrif_CurChildgrid => NULL() 106 111 ! 107 112 !=================================================================================================== -
vendors/AGRIF/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modinterp.F90
r7752 r13027 127 127 ! 128 128 INTEGER :: i,j,k,l,m,n 129 integer :: i1,j1,k1 129 130 INTEGER, DIMENSION(nbdim) :: pttruetab,cetruetab 130 131 INTEGER, DIMENSION(nbdim) :: indmin, indmax … … 132 133 #if defined AGRIF_MPI 133 134 INTEGER, DIMENSION(nbdim) :: indminglob2,indmaxglob2 135 INTEGER, DIMENSION(nbdim) :: indminglob3,indmaxglob3 136 INTEGER, DIMENSION(:,:),ALLOCATABLE :: indminglob_chunks, indmaxglob_chunks 137 INTEGER, DIMENSION(:,:),ALLOCATABLE :: indminglob2_chunks,indmaxglob2_chunks 138 INTEGER, DIMENSION(:,:),ALLOCATABLE :: indminglob3_chunks,indmaxglob3_chunks 134 139 #endif 135 140 LOGICAL, DIMENSION(nbdim) :: noraftab … … 138 143 INTEGER, DIMENSION(nbdim,2,2), INTENT(OUT) :: childarray 139 144 INTEGER, DIMENSION(nbdim,2,2) :: parentarray 145 INTEGER, DIMENSION(nbdim,2,2) :: parentarray_decal 140 146 LOGICAL :: member 147 LOGICAL,DIMENSION(:),ALLOCATABLE :: member_chuncks 148 INTEGER,DIMENSION(:,:),ALLOCATABLE :: decal_chunks 141 149 LOGICAL :: find_list_interp 142 150 ! … … 148 156 INTEGER, DIMENSION(nbdim,4,0:Agrif_Nbprocs-1) :: tab4 149 157 INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1,8) :: tab4t 158 INTEGER, DIMENSION(nbdim,2) :: tab5 159 INTEGER, DIMENSION(nbdim,2,0:Agrif_Nbprocs-1) :: tab6 160 INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1,2) :: tab5t 150 161 LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: memberinall 151 162 LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: sendtoproc1, recvfromproc1 … … 154 165 ! 155 166 #endif 167 ! CHUNK (periodicity) 168 INTEGER :: nb_chunks 169 INTEGER :: agrif_external_switch_index 170 INTEGER, DIMENSION(2) :: test_orientation 171 !INTEGER, DIMENSION(2,nbdim,2,2) :: parentarray_chunk 172 INTEGER, DIMENSION(:,:,:,:), ALLOCATABLE :: parentarray_chunk 173 INTEGER, DIMENSION(:,:,:,:), ALLOCATABLE :: parentarray_chunk_decal 174 INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: bounds_chunks 175 logical,dimension(:),allocatable :: correction_required 156 176 ! 157 177 type(Agrif_Variable), pointer, save :: tempC => NULL() ! Temporary child grid variable … … 168 188 pttab, petab, pttab_Child, pttab_Parent, nbdim, & 169 189 indmin, indmax, indminglob, indmaxglob, & 170 pttruetab, cetruetab, memberin & 190 pttruetab, cetruetab, memberin, & 191 parentarray_chunk,parentarray_chunk_decal,decal_chunks, & 192 correction_required,member_chuncks,nb_chunks & 171 193 #if defined AGRIF_MPI 172 194 ,indminglob2, indmaxglob2, parentarray, & … … 181 203 pttab, petab, Agrif_Procrank, coords, & 182 204 pttruetab, cetruetab, memberin) 205 206 if (agrif_debug_interp) then 207 print *,'************CHILDBOUNDS*********************************' 208 #ifdef AGRIF_MPI 209 print *,'Processeur ',Agrif_Procrank 210 #endif 211 print *,'memberin ',memberin 212 do i = 1 , nbdim 213 print *,'Direction ',i,' indices debut: ',pttab(i),pttruetab(i) 214 print *,'Direction ',i,' indices fin : ',petab(i),cetruetab(i) 215 enddo 216 print *,'*********************************************' 217 endif 218 183 219 call Agrif_Parentbounds(type_interp,nbdim,indminglob,indmaxglob, & 184 220 s_Parent_temp,s_Child_temp, & … … 188 224 pttab_Child,pttab_Parent, & 189 225 child%root_var % posvar, coords) 226 227 if (agrif_debug_interp) then 228 print *,'************PARENTBOUNDS*********************************' 229 #ifdef AGRIF_MPI 230 print *,'Processeur ',Agrif_Procrank 231 #endif 232 do i = 1 , nbdim 233 print *,'Direction ',i,' indices debut: ',pttab(i),indminglob(i) 234 print *,'Direction ',i,' indices fin : ',petab(i),indmaxglob(i) 235 enddo 236 237 do i = 1 , nbdim 238 print *,'Direction ',i,' s_parent_temp: ',s_parent_temp(i) 239 print *,'Direction ',i,' s_Child_temp : ',s_Child_temp(i) 240 enddo 241 print *,'*********************************************' 242 endif 243 190 244 #if defined AGRIF_MPI 191 245 if (memberin) then … … 197 251 pttab_Child,pttab_Parent, & 198 252 child%root_var % posvar, coords) 253 254 endif 255 if (agrif_debug_interp) then 256 print *,'************PARENTBOUNDSMPI*********************************' 257 #ifdef AGRIF_MPI 258 print *,'Processeur ',Agrif_Procrank 259 #endif 260 do i = 1 , nbdim 261 print *,'Direction ',i,' indices debut: ',pttruetab(i),indmin(i) 262 print *,'Direction ',i,' indices fin : ',cetruetab(i),indmax(i) 263 enddo 264 265 do i = 1 , nbdim 266 print *,'Direction ',i,' s_parent_temp: ',s_parent_temp(i) 267 print *,'Direction ',i,' s_Child_temp : ',s_Child_temp(i) 268 enddo 269 print *,'*********************************************' 199 270 endif 200 271 … … 202 273 call Agrif_get_var_bounds_array(parent,lowerbound,upperbound,nbdim) 203 274 call Agrif_ChildGrid_to_ParentGrid() 204 ! 205 call Agrif_Childbounds(nbdim,lowerbound,upperbound, & 206 indminglob,indmaxglob, local_proc, coords, & 207 indminglob2,indmaxglob2,member) 208 ! 209 if (member) then 210 call Agrif_GlobalToLocalBounds(parentarray, & 211 lowerbound, upperbound, & 212 indminglob2, indmaxglob2, coords,& 213 nbdim, local_proc, member) 275 276 parentarray(:,1,1) = indminglob 277 parentarray(:,2,1) = indmaxglob 278 parentarray(:,1,2) = indminglob 279 parentarray(:,2,2) = indmaxglob 280 281 if (associated(agrif_external_mapping)) then 282 283 call agrif_external_mapping(nbdim,child%root_var % posvar(1),child%root_var % posvar(2), & 284 parentarray,parentarray_chunk,correction_required,nb_chunks) 285 allocate(decal_chunks(nb_chunks,nbdim)) 286 do i=1,nb_chunks 287 decal_chunks(i,:)=parentarray_chunk(i,:,1,1)-parentarray_chunk(i,:,1,2) 288 enddo 289 else 290 nb_chunks=1 291 allocate(correction_required(nb_chunks)) 292 correction_required=.FALSE. 293 allocate(parentarray_chunk(nb_chunks,nbdim,2,2)) 294 parentarray_chunk(1,:,:,:)=parentarray 295 allocate(decal_chunks(nb_chunks,nbdim)) 296 decal_chunks=0 214 297 endif 298 if (agrif_debug_interp) then 299 print *,'AVANT PARENTCHILDBOUNDS' 300 print *,'nombre de chunks ',nb_chunks 301 do i=1,nb_chunks 302 print *,'CHUNK Number : ',i 303 do j=1,nbdim 304 print *,'Direction ',j 305 print *,'MIN MAX (2) = ',parentarray_chunk(i,j,1,2),parentarray_chunk(i,j,2,2) 306 print *,'MIN MAX (1) = ',parentarray_chunk(i,j,1,1),parentarray_chunk(i,j,2,1) 307 enddo 308 enddo 309 print *,'APRES PARENTCHILDBOUNDS' 310 endif 311 312 allocate(indminglob_chunks(nb_chunks,nbdim)) 313 allocate(indmaxglob_chunks(nb_chunks,nbdim)) 314 allocate(indminglob2_chunks(nb_chunks,nbdim)) 315 allocate(indmaxglob2_chunks(nb_chunks,nbdim)) 316 allocate(indminglob3_chunks(nb_chunks,nbdim)) 317 allocate(indmaxglob3_chunks(nb_chunks,nbdim)) 318 allocate(member_chuncks(nb_chunks)) 319 320 do i=1,nb_chunks 321 indminglob_chunks(i,:) = parentarray_chunk(i,:,1,2) 322 indmaxglob_chunks(i,:) = parentarray_chunk(i,:,2,2) 323 enddo 324 325 do i=1,nb_chunks 326 327 call Agrif_Childbounds(nbdim,lowerbound,upperbound, & 328 indminglob_chunks(i,:),indmaxglob_chunks(i,:), local_proc, coords, & 329 indminglob2_chunks(i,:),indmaxglob2_chunks(i,:),member_chuncks(i), & 330 indminglob3_chunks(i,:),indmaxglob3_chunks(i,:)) 331 enddo 332 ! 333 ! call Agrif_Childbounds(nbdim,lowerbound,upperbound, & 334 ! indminglob,indmaxglob, local_proc, coords, & 335 ! indminglob2,indmaxglob2,member, & 336 ! indminglob3,indmaxglob3,check_perio=.TRUE.) 337 338 if (agrif_debug_interp) then 339 print *,'************CHILDBOUNDSPARENTMPI*********************************' 340 #ifdef AGRIF_MPI 341 print *,'Processeur ',Agrif_Procrank 342 #endif 343 do j=1,nb_chunks 344 print *,'Chunk number ',j 345 346 do i = 1 , nbdim 347 print *,'Direction ',i,' indices debut: ',indminglob_chunks(j,i),indminglob2_chunks(j,i),indminglob3_chunks(j,i) 348 print *,'Direction ',i,' indices fin : ',indmaxglob_chunks(j,i),indmaxglob2_chunks(j,i),indmaxglob3_chunks(j,i) 349 enddo 350 enddo 351 print *,'*********************************************' 352 endif 353 ! 354 ! if (member) then 355 ! call Agrif_GlobalToLocalBounds(parentarray, & 356 ! lowerbound, upperbound, & 357 ! indminglob2, indmaxglob2, coords,& 358 ! nbdim, local_proc, member,check_perio=.TRUE.) 359 ! if (agrif_debug_interp) then 360 ! do i=1,nbdim 361 ! print *,'parentarray = ',i,parentarray(i,1,1),parentarray(i,2,1), & 362 ! parentarray(i,1,2),parentarray(i,2,2) 363 ! enddo 364 ! endif 365 ! endif 366 367 allocate(parentarray_chunk_decal(nb_chunks,nbdim,2,2)) 368 do j=1,nb_chunks 369 if (agrif_debug_interp) print *,'CHUNK = ',j 370 if (member_chuncks(j)) then 371 ! call Agrif_GlobalToLocalBounds(parentarray_chunk(j,:,:,:), & 372 ! lowerbound, upperbound, & 373 ! indminglob2_chunks(j,:), indmaxglob2_chunks(j,:), coords, & 374 ! nbdim, local_proc, member_chuncks(j),check_perio=.TRUE.) 375 376 call Agrif_GlobalToLocalBounds(parentarray_chunk(j,:,:,:), & 377 lowerbound, upperbound, & 378 indminglob2_chunks(j,:), indmaxglob2_chunks(j,:), coords, & 379 nbdim, local_proc, member_chuncks(j)) 380 381 if (correction_required(j)) then 382 do i=1,2 383 test_orientation(1)=agrif_external_switch_index(child%root_var % posvar(1),child%root_var % posvar(2), & 384 parentarray_chunk(j,i,1,1),i) 385 test_orientation(2)=agrif_external_switch_index(child%root_var % posvar(1),child%root_var % posvar(2), & 386 parentarray_chunk(j,i,2,1),i) 387 parentarray_chunk_decal(j,i,1,1)=minval(test_orientation) 388 parentarray_chunk_decal(j,i,2,1)=maxval(test_orientation) 389 enddo 390 do i=3,nbdim 391 parentarray_chunk_decal(j,i,:,1) = parentarray_chunk(j,i,:,1)+decal_chunks(j,i) 392 enddo 393 else 394 do i=1,nbdim 395 parentarray_chunk_decal(j,i,:,1) = parentarray_chunk(j,i,:,1)+decal_chunks(j,i) 396 enddo 397 endif 398 399 if (agrif_debug_interp) then 400 do i=1,nbdim 401 print *,'parentarray = ',i,parentarray_chunk(j,i,1,1),parentarray_chunk(j,i,2,1), & 402 parentarray_chunk(j,i,1,2),parentarray_chunk(j,i,2,2) 403 print *,'parentarraydecal = ',i,parentarray_chunk_decal(j,i,1,1),parentarray_chunk_decal(j,i,2,1) 404 enddo 405 endif 406 endif 407 enddo 408 409 parentarray(:,1,:)=Huge(1) 410 parentarray(:,2,:)=-Huge(1) 411 indminglob2=Huge(1) 412 indmaxglob2=-Huge(1) 413 indminglob3=Huge(1) 414 indmaxglob3=-Huge(1) 415 member = .FALSE. 416 do j=1,nb_chunks 417 if (member_chuncks(j)) then 418 do i=1,nbdim 419 parentarray(i,1,1) = min(parentarray(i,1,1),parentarray_chunk_decal(j,i,1,1)) 420 parentarray(i,1,2) = min(parentarray(i,1,2),parentarray_chunk(j,i,1,2)) 421 parentarray(i,2,1) = max(parentarray(i,2,1),parentarray_chunk_decal(j,i,2,1)) 422 parentarray(i,2,2) = max(parentarray(i,2,2),parentarray_chunk(j,i,2,2)) 423 enddo 424 if (correction_required(j)) then 425 if (agrif_debug_interp) then 426 do i=1,nbdim 427 print *,'direction ',i 428 print *,'glob2_chuk = ',indminglob2_chunks(j,i),indmaxglob2_chunks(j,i) 429 print *,'glob3_chuk = ',indminglob3_chunks(j,i),indmaxglob3_chunks(j,i) 430 enddo 431 endif 432 do i=1,2 433 test_orientation(1)=agrif_external_switch_index(child%root_var % posvar(1),child%root_var % posvar(2), & 434 indminglob2_chunks(j,i),i) 435 test_orientation(2)=agrif_external_switch_index(child%root_var % posvar(1),child%root_var % posvar(2), & 436 indmaxglob2_chunks(j,i),i) 437 indminglob2(i)=min(indminglob2(i),minval(test_orientation)) 438 indmaxglob2(i)=max(indmaxglob2(i),maxval(test_orientation)) 439 enddo 440 441 do i=1,2 442 test_orientation(1)=agrif_external_switch_index(child%root_var % posvar(1),child%root_var % posvar(2), & 443 indminglob3_chunks(j,i),i) 444 test_orientation(2)=agrif_external_switch_index(child%root_var % posvar(1),child%root_var % posvar(2), & 445 indmaxglob3_chunks(j,i),i) 446 indminglob3(i)=min(indminglob3(i),minval(test_orientation)) 447 indmaxglob3(i)=max(indmaxglob3(i),maxval(test_orientation)) 448 enddo 449 450 do i=3,nbdim 451 indminglob2(i)=min(indminglob2(i),indminglob2_chunks(j,i)+decal_chunks(j,i)) 452 indmaxglob2(i)=max(indmaxglob2(i),indmaxglob2_chunks(j,i)+decal_chunks(j,i)) 453 indminglob3(i)=min(indminglob3(i),indminglob3_chunks(j,i)+decal_chunks(j,i)) 454 indmaxglob3(i)=max(indmaxglob3(i),indmaxglob3_chunks(j,i)+decal_chunks(j,i)) 455 enddo 456 else 457 do i=1,nbdim 458 indminglob2(i)=min(indminglob2(i),indminglob2_chunks(j,i)+decal_chunks(j,i)) 459 indmaxglob2(i)=max(indmaxglob2(i),indmaxglob2_chunks(j,i)+decal_chunks(j,i)) 460 indminglob3(i)=min(indminglob3(i),indminglob3_chunks(j,i)+decal_chunks(j,i)) 461 indmaxglob3(i)=max(indmaxglob3(i),indmaxglob3_chunks(j,i)+decal_chunks(j,i)) 462 enddo 463 endif 464 465 member = .TRUE. 466 endif 467 enddo 215 468 216 469 call Agrif_ParentGrid_to_ChildGrid() 470 471 if (agrif_debug_interp) then 472 print *,'************ FINAL PARENTARRAY *****************' 473 #ifdef AGRIF_MPI 474 print *,'Processeur ',Agrif_Procrank,' MEMBER = ',member 475 do i=1,nbdim 476 print *,'Direction ',i,' indices debut = ',parentarray(i,1,1),parentarray(i,1,2) 477 print *,'Direction ',i,' indices fin = ',parentarray(i,2,1),parentarray(i,2,2) 478 enddo 479 #endif 480 endif 481 482 if (agrif_debug_interp) then 483 print *,'************ FINAL INDMINGLOB *****************' 484 #ifdef AGRIF_MPI 485 print *,'Processeur ',Agrif_Procrank,' MEMBER = ',member 486 do i=1,nbdim 487 print *,'Direction ',i,' indices debut = ',indminglob2(i),indminglob3(i) 488 print *,'Direction ',i,' indices fin = ',indmaxglob2(i),indmaxglob3(i) 489 enddo 490 #endif 491 endif 492 217 493 #else 218 494 parentarray(:,1,1) = indminglob … … 220 496 parentarray(:,1,2) = indminglob 221 497 parentarray(:,2,2) = indmaxglob 498 499 500 if (associated(agrif_external_mapping)) then 501 call Agrif_ChildGrid_to_ParentGrid() 502 call agrif_external_mapping(nbdim,child%root_var % posvar(1),child%root_var % posvar(2), & 503 parentarray,parentarray_chunk,correction_required,nb_chunks) 504 call Agrif_ParentGrid_to_ChildGrid() 505 allocate(decal_chunks(nb_chunks,nbdim)) 506 do i=1,nb_chunks 507 decal_chunks(i,:)=parentarray_chunk(i,:,1,1)-parentarray_chunk(i,:,1,2) 508 enddo 509 else 510 nb_chunks=1 511 allocate(correction_required(nb_chunks)) 512 correction_required=.FALSE. 513 allocate(parentarray_chunk(nb_chunks,nbdim,2,2)) 514 parentarray_chunk(1,:,:,:)=parentarray 515 endif 516 if (agrif_debug_interp) then 517 print *,'AVANT PARENTCHILDBOUNDS' 518 print *,'nombre de chunks ',nb_chunks 519 do i=1,nb_chunks 520 print *,'CHUNK Number : ',i 521 do j=1,nbdim 522 print *,'Direction ',j 523 print *,'MIN MAX (2) = ',parentarray_chunk(i,j,1,2),parentarray_chunk(i,j,2,2) 524 print *,'MIN MAX (1) = ',parentarray_chunk(i,j,1,1),parentarray_chunk(i,j,2,1) 525 enddo 526 enddo 527 print *,'APRES PARENTCHILDBOUNDS' 528 endif 529 allocate(member_chuncks(nb_chunks)) 530 allocate(parentarray_chunk_decal(nb_chunks,nbdim,2,2)) 531 member_chuncks = .TRUE. 532 member = .TRUE. 533 do j=1,nb_chunks 534 if (agrif_debug_interp) print *,'CHUNK = ',j 535 if (member_chuncks(j)) then 536 do i=1,nbdim 537 parentarray_chunk_decal(j,i,:,1) = parentarray_chunk(j,i,:,1) !+decal_chunks(j,i) 538 if (agrif_debug_interp) then 539 print *,'ENCORE = ',parentarray_chunk(j,i,:,1),parentarray_chunk_decal(j,i,:,1) 540 endif 541 enddo 542 if (agrif_debug_interp) then 543 do i=1,nbdim 544 print *,'parentarray = ',i,parentarray_chunk(j,i,1,1),parentarray_chunk(j,i,2,1), & 545 parentarray_chunk(j,i,1,2),parentarray_chunk(j,i,2,2) 546 print *,'parentarraydecal = ',i,parentarray_chunk_decal(j,i,1,1),parentarray_chunk_decal(j,i,2,1) 547 enddo 548 endif 549 endif 550 enddo 551 552 222 553 indmin = indminglob 223 554 indmax = indmaxglob 224 555 member = .TRUE. 225 556 #endif 557 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 558 ! Correct for non refined directions 559 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 560 do i=1,nbdim 561 if (coords(i) == 0) then 562 indmin(i) = indminglob(i) 563 indmax(i) = indmaxglob(i) 564 pttruetab(i) = indminglob(i) 565 cetruetab(i) = indmaxglob(i) 566 endif 567 enddo 226 568 227 569 else … … 241 583 s_Child_temp = s_Child + (pttab - pttab_Child) * ds_Child 242 584 #endif 585 243 586 endif 587 588 if (agrif_debug_interp) then 589 print *,'************SPARENTCHILD*********************************' 590 #ifdef AGRIF_MPI 591 print *,'Processeur ',Agrif_Procrank 592 #endif 593 do i = 1 , nbdim 594 print *,'Direction ',i,' s_Parent_temp : ',s_Parent_temp(i),indmin(i) 595 print *,'Direction ',i,' s_Child_temp : ',s_Child_temp(i),pttruetab(i) 596 enddo 597 print *,'*********************************************' 598 endif 599 600 call Agrif_get_var_bounds_array(parent,lowerbound,upperbound,nbdim) 244 601 ! 245 602 if (member) then … … 248 605 call Agrif_array_allocate(tempP,parentarray(:,1,1),parentarray(:,2,1),nbdim) 249 606 call Agrif_var_set_array_tozero(tempP,nbdim) 250 251 call Agrif_ChildGrid_to_ParentGrid() 252 ! 607 endif 608 Agrif_CurChildgrid=>Agrif_Curgrid 609 call Agrif_ChildGrid_to_ParentGrid() 610 do i=1,nb_chunks 611 if (agrif_debug_interp) then 612 print *,'PROCNAME POUR CHUCNK ',i 613 endif 614 615 if (member_chuncks(i)) then 253 616 select case (nbdim) 254 617 case(1) 255 call procname(tempP%array1, & 256 parentarray(1,1,2),parentarray(1,2,2),.TRUE.,nb,ndir) 618 ! call procname(tempP%array1, & 619 ! parentarray(1,1,2),parentarray(1,2,2),.TRUE.,nb,ndir) 620 621 call procname(tempP%array1(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1)), & 622 parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2),.TRUE.,nb,ndir) 623 257 624 case(2) 258 call procname(tempP%array2, & 259 parentarray(1,1,2),parentarray(1,2,2), & 260 parentarray(2,1,2),parentarray(2,2,2),.TRUE.,nb,ndir) 625 ! call procname(tempP%array2, & 626 ! parentarray(1,1,2),parentarray(1,2,2), & 627 ! parentarray(2,1,2),parentarray(2,2,2),.TRUE.,nb,ndir) 628 629 call procname(tempP%array2(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 630 parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1)), & 631 parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2), & 632 parentarray_chunk(i,2,1,2),parentarray_chunk(i,2,2,2),.TRUE.,nb,ndir) 633 if (agrif_debug_interp) print *,'SORTIE DE PROCNAME' 634 if (correction_required(i)) then 635 call correct_field(tempP%array2(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 636 parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1)), & 637 parentarray_chunk_decal(i,1,1,1),parentarray_chunk_decal(i,1,2,1), & 638 parentarray_chunk_decal(i,2,1,1),parentarray_chunk_decal(i,2,2,1)) 639 endif 640 261 641 case(3) 262 call procname(tempP%array3, & 263 parentarray(1,1,2),parentarray(1,2,2), & 264 parentarray(2,1,2),parentarray(2,2,2), & 265 parentarray(3,1,2),parentarray(3,2,2),.TRUE.,nb,ndir) 642 call procname(tempP%array3(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 643 parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1), & 644 parentarray_chunk_decal(i,3,1,1):parentarray_chunk_decal(i,3,2,1)), & 645 parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2), & 646 parentarray_chunk(i,2,1,2),parentarray_chunk(i,2,2,2), & 647 parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2),.TRUE.,nb,ndir) 648 649 if (agrif_debug_interp) then 650 print *,'CHUNK = ',i 651 print *,'NBNDIR = ',nb,ndir,correction_required(i) 652 print *,'TEMPARRAY3 INDEX LOCAUX PUIS GLOBAUX' 653 print *,parentarray_chunk_decal(i,1,1,1),parentarray_chunk_decal(i,1,2,1) 654 print *,parentarray_chunk_decal(i,2,1,1),parentarray_chunk_decal(i,2,2,1) 655 print *,parentarray_chunk_decal(i,3,1,1),parentarray_chunk_decal(i,3,2,1) 656 print *,parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2) 657 print *,parentarray_chunk(i,2,1,2),parentarray_chunk(i,2,2,2) 658 print *,parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2) 659 do j1=parentarray_chunk_decal(i,2,1,1),parentarray_chunk_decal(i,2,2,1) 660 do i1=parentarray_chunk_decal(i,1,1,1),parentarray_chunk_decal(i,1,2,1) 661 print *,'valprocname = ',i1,j1,tempP%array3(i1,j1,1) 662 enddo 663 enddo 664 endif 665 if (correction_required(i)) then 666 do k=parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2) 667 call correct_field(tempP%array3(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 668 parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1),k), & 669 parentarray_chunk_decal(i,1,1,1),parentarray_chunk_decal(i,1,2,1), & 670 parentarray_chunk_decal(i,2,1,1),parentarray_chunk_decal(i,2,2,1)) 671 enddo 672 if (agrif_debug_interp) then 673 do j1=parentarray_chunk_decal(i,2,1,1),parentarray_chunk_decal(i,2,2,1) 674 do i1=parentarray_chunk_decal(i,1,1,1),parentarray_chunk_decal(i,1,2,1) 675 print *,'valprocname apres correction = ',i1,j1,tempP%array3(i1,j1,1) 676 enddo 677 enddo 678 endif 679 endif 680 681 ! call procname(tempP%array3, & 682 ! parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2), & 683 ! parentarray_chunk(i,2,1,2),parentarray_chunk(i,2,2,2), & 684 ! parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2),.TRUE.,nb,ndir) 266 685 case(4) 267 call procname(tempP%array4, & 268 parentarray(1,1,2),parentarray(1,2,2), & 269 parentarray(2,1,2),parentarray(2,2,2), & 270 parentarray(3,1,2),parentarray(3,2,2), & 271 parentarray(4,1,2),parentarray(4,2,2),.TRUE.,nb,ndir) 686 687 call procname(tempP%array4(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 688 parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1), & 689 parentarray_chunk_decal(i,3,1,1):parentarray_chunk_decal(i,3,2,1), & 690 parentarray_chunk_decal(i,4,1,1):parentarray_chunk_decal(i,4,2,1)), & 691 parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2), & 692 parentarray_chunk(i,2,1,2),parentarray_chunk(i,2,2,2), & 693 parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2), & 694 parentarray_chunk(i,4,1,2),parentarray_chunk(i,4,2,2),.TRUE.,nb,ndir) 695 696 if (correction_required(i)) then 697 do l=parentarray_chunk(i,4,1,2),parentarray_chunk(i,4,2,2) 698 do k=parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2) 699 call correct_field(tempP%array4(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 700 parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1),k,l), & 701 parentarray_chunk_decal(i,1,1,1),parentarray_chunk_decal(i,1,2,1), & 702 parentarray_chunk_decal(i,2,1,1),parentarray_chunk_decal(i,2,2,1)) 703 enddo 704 enddo 705 endif 706 707 ! call procname(tempP%array4, & 708 ! parentarray(1,1,2),parentarray(1,2,2), & 709 ! parentarray(2,1,2),parentarray(2,2,2), & 710 ! parentarray(3,1,2),parentarray(3,2,2), & 711 ! parentarray(4,1,2),parentarray(4,2,2),.TRUE.,nb,ndir) 272 712 case(5) 273 call procname(tempP%array5, & 274 parentarray(1,1,2),parentarray(1,2,2), & 275 parentarray(2,1,2),parentarray(2,2,2), & 276 parentarray(3,1,2),parentarray(3,2,2), & 277 parentarray(4,1,2),parentarray(4,2,2), & 278 parentarray(5,1,2),parentarray(5,2,2),.TRUE.,nb,ndir) 713 714 call procname(tempP%array5(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 715 parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1), & 716 parentarray_chunk_decal(i,3,1,1):parentarray_chunk_decal(i,3,2,1), & 717 parentarray_chunk_decal(i,4,1,1):parentarray_chunk_decal(i,4,2,1), & 718 parentarray_chunk_decal(i,5,1,1):parentarray_chunk_decal(i,5,2,1)), & 719 parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2), & 720 parentarray_chunk(i,2,1,2),parentarray_chunk(i,2,2,2), & 721 parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2), & 722 parentarray_chunk(i,4,1,2),parentarray_chunk(i,4,2,2), & 723 parentarray_chunk(i,5,1,2),parentarray_chunk(i,5,2,2),.TRUE.,nb,ndir) 724 725 if (correction_required(i)) then 726 do m=parentarray_chunk(i,5,1,2),parentarray_chunk(i,5,2,2) 727 do l=parentarray_chunk(i,4,1,2),parentarray_chunk(i,4,2,2) 728 do k=parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2) 729 call correct_field(tempP%array5(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 730 parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1),k,l,m), & 731 parentarray_chunk_decal(i,1,1,1),parentarray_chunk_decal(i,1,2,1), & 732 parentarray_chunk_decal(i,2,1,1),parentarray_chunk_decal(i,2,2,1)) 733 enddo 734 enddo 735 enddo 736 endif 737 738 ! call procname(tempP%array5, & 739 ! parentarray(1,1,2),parentarray(1,2,2), & 740 ! parentarray(2,1,2),parentarray(2,2,2), & 741 ! parentarray(3,1,2),parentarray(3,2,2), & 742 ! parentarray(4,1,2),parentarray(4,2,2), & 743 ! parentarray(5,1,2),parentarray(5,2,2),.TRUE.,nb,ndir) 279 744 case(6) 280 call procname(tempP%array6, & 281 parentarray(1,1,2),parentarray(1,2,2), & 282 parentarray(2,1,2),parentarray(2,2,2), & 283 parentarray(3,1,2),parentarray(3,2,2), & 284 parentarray(4,1,2),parentarray(4,2,2), & 285 parentarray(5,1,2),parentarray(5,2,2), & 286 parentarray(6,1,2),parentarray(6,2,2),.TRUE.,nb,ndir) 745 746 call procname(tempP%array6(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 747 parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1), & 748 parentarray_chunk_decal(i,3,1,1):parentarray_chunk_decal(i,3,2,1), & 749 parentarray_chunk_decal(i,4,1,1):parentarray_chunk_decal(i,4,2,1), & 750 parentarray_chunk_decal(i,5,1,1):parentarray_chunk_decal(i,5,2,1), & 751 parentarray_chunk_decal(i,6,1,1):parentarray_chunk_decal(i,6,2,1)), & 752 parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2), & 753 parentarray_chunk(i,2,1,2),parentarray_chunk(i,2,2,2), & 754 parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2), & 755 parentarray_chunk(i,4,1,2),parentarray_chunk(i,4,2,2), & 756 parentarray_chunk(i,5,1,2),parentarray_chunk(i,5,2,2), & 757 parentarray_chunk(i,6,1,2),parentarray_chunk(i,6,2,2),.TRUE.,nb,ndir) 758 759 ! call procname(tempP%array6, & 760 ! parentarray(1,1,2),parentarray(1,2,2), & 761 ! parentarray(2,1,2),parentarray(2,2,2), & 762 ! parentarray(3,1,2),parentarray(3,2,2), & 763 ! parentarray(4,1,2),parentarray(4,2,2), & 764 ! parentarray(5,1,2),parentarray(5,2,2), & 765 ! parentarray(6,1,2),parentarray(6,2,2),.TRUE.,nb,ndir) 287 766 end select 288 767 ! 289 call Agrif_ParentGrid_to_ChildGrid()290 768 ! 291 769 endif 770 enddo 771 call Agrif_ParentGrid_to_ChildGrid() 772 nullify(Agrif_CurChildgrid) 292 773 293 774 #if defined AGRIF_MPI … … 298 779 tab3(:,3) = indmin(:) 299 780 tab3(:,4) = indmax(:) 781 tab5(:,1) = indminglob3(:) 782 tab5(:,2) = indmaxglob3(:) 783 if (agrif_debug_interp) then 784 print *,'********************' 785 print *,'MPI VARIABLES' 786 print *,'INDMINGLOB2' 787 do i=1,nbdim 788 print *,'Direction ',i,indminglob2(i),indmaxglob2(i) 789 enddo 790 print *,'INDMIN' 791 do i=1,nbdim 792 print *,'Direction ',i,indmin(i),indmax(i) 793 enddo 794 print *,'INDMINGLOB3' 795 do i=1,nbdim 796 print *,'Direction ',i,indminglob3(i),indmaxglob3(i) 797 enddo 798 endif 300 799 ! 301 800 call MPI_ALLGATHER(tab3,4*nbdim,MPI_INTEGER,tab4,4*nbdim,MPI_INTEGER,Agrif_mpi_comm,code) 302 801 call MPI_ALLGATHER(tab5,2*nbdim,MPI_INTEGER,tab6,2*nbdim,MPI_INTEGER,Agrif_mpi_comm,code) 303 802 if (.not.associated(tempPextend)) allocate(tempPextend) 304 803 … … 309 808 enddo 310 809 enddo 810 enddo 811 812 do k=0,Agrif_Nbprocs-1 813 do j=1,2 814 do i=1,nbdim 815 tab5t(i,k,j) = tab6(i,j,k) 816 enddo 817 enddo 311 818 enddo 312 819 … … 319 826 sendtoproc1,recvfromproc1, & 320 827 tab4t(:,:,5),tab4t(:,:,6), & 321 tab4t(:,:,7),tab4t(:,:,8) ) 828 tab4t(:,:,7),tab4t(:,:,8), & 829 tab5t(:,:,1),tab5t(:,:,2)) 322 830 endif 323 831 … … 335 843 indminglob,indmaxglob, & 336 844 pttruetab,cetruetab, & 337 memberin,nbdim & 845 memberin,nbdim, & 846 parentarray_chunk,parentarray_chunk_decal,decal_chunks,& 847 correction_required,member_chuncks,nb_chunks & 338 848 #if defined AGRIF_MPI 339 849 ,indminglob2,indmaxglob2, & … … 391 901 ds_Child(1:2), ds_Parent(1:2) ) 392 902 case(3) 903 if (agrif_debug_interp) then 904 print *,'APRES ECHANGE' 905 print *,'nombre de chunks ',nb_chunks 906 print *,'indmin = ',indmin 907 print *,'indmax = ',indmax 908 do i=1,nb_chunks 909 print *,'CHUNK Number : ',i 910 print *,'MEMBER = ',member_chuncks(i) 911 print *,'Correction = ',correction_required(i) 912 enddo 913 endif 914 915 if (agrif_debug_interp) then 916 ! if ((nb==1).AND.(ndir==1)) then 917 print *,'valeur parent = ' 918 do j=indmin(2),indmax(2) 919 do i=indmin(1),indmax(1) 920 print *,'par = ',i,j,tempPextend%array3(i,j,1) 921 enddo 922 enddo 923 924 ! endif 925 endif 393 926 call Agrif_Interp_3D_recursive( type_interp(1:3), & 394 927 tempPextend % array3, & … … 398 931 s_Child_temp(1:3), s_Parent_temp(1:3), & 399 932 ds_Child(1:3), ds_Parent(1:3) ) 933 if (agrif_debug_interp) then 934 ! if ((nb==1).AND.(ndir==1)) then 935 print *,'valeur enfnat = ' 936 do j=pttruetab(2),cetruetab(2) 937 do i=pttruetab(1),cetruetab(1) 938 print *,'par = ',i,j,tempC%array3(i,j,1) 939 enddo 940 enddo 941 942 ! endif 943 endif 400 944 case(4) 401 945 call Agrif_Interp_4D_recursive( type_interp(1:4), & … … 676 1220 childarray(2,1,1):childarray(2,2,1), & 677 1221 childarray(3,1,1):childarray(3,2,1)) 1222 if (agrif_debug_interp) then 1223 if ((nb==1).AND.(ndir==1)) then 1224 print *,'valeur enfnat2 = ' 1225 do j=childarray(2,1,2),childarray(2,2,2) 1226 do i=childarray(1,1,2),childarray(1,2,2) 1227 print *,'par = ',i,j,parray3(i,j,1) 1228 enddo 1229 enddo 1230 1231 endif 1232 endif 678 1233 case (4) 679 1234 parray4(childarray(1,1,2):childarray(1,2,2), & … … 723 1278 #if defined AGRIF_MPI 724 1279 if (member) then 1280 if (agrif_debug_interp) then 1281 print *,'ALLCOATED 0 = ',allocated(tempP%array3),size(tempP%array3) 1282 endif 725 1283 call Agrif_array_deallocate(tempP,nbdim) 726 1284 endif … … 774 1332 indmin(i) = indmin(i) - 2 775 1333 indmax(i) = indmax(i) + 2 776 777 if (Agrif_UseSpecialValue) then778 indmin(i) = indmin(i)-MaxSearch779 indmax(i) = indmax(i)+MaxSearch780 endif781 782 1334 elseif ( (type_interp(i) /= Agrif_constant) .and. & 783 1335 (type_interp(i) /= Agrif_linear) ) then 784 1336 indmin(i) = indmin(i) - 1 785 1337 indmax(i) = indmax(i) + 1 786 787 if (Agrif_UseSpecialValue) then788 indmin(i) = indmin(i)-MaxSearch789 indmax(i) = indmax(i)+MaxSearch790 endif791 792 elseif ( (type_interp(i) == Agrif_constant) .or. &793 (type_interp(i) == Agrif_linear) ) then794 if (Agrif_UseSpecialValue) then795 indmin(i) = indmin(i)-MaxSearch796 indmax(i) = indmax(i)+MaxSearch797 endif798 799 1338 endif 800 1339 ! … … 1372 1911 function Agrif_Find_list_interp ( list_interp, pttab, petab, pttab_Child, pttab_Parent, & 1373 1912 nbdim, indmin, indmax, indminglob, indmaxglob, & 1374 pttruetab, cetruetab, memberin & 1913 pttruetab, cetruetab, memberin, & 1914 parentarray_chunk,parentarray_chunk_decal,decal_chunks, & 1915 correction_required,member_chuncks,nb_chunks & 1375 1916 #if defined AGRIF_MPI 1376 1917 ,indminglob2, indmaxglob2, parentarray, & … … 1386 1927 integer, dimension(nbdim), intent(out) :: pttruetab, cetruetab 1387 1928 logical, intent(out) :: memberin 1929 integer :: nb_chunks 1930 integer, dimension(:,:,:,:), allocatable :: parentarray_chunk 1931 integer, dimension(:,:,:,:), allocatable :: parentarray_chunk_decal 1932 integer, dimension(:,:),allocatable :: decal_chunks 1933 logical, dimension(:),allocatable :: correction_required 1934 logical, dimension(:),allocatable :: member_chuncks 1388 1935 #if defined AGRIF_MPI 1389 1936 integer, dimension(nbdim), intent(out) :: indminglob2, indmaxglob2 … … 1441 1988 #endif 1442 1989 memberin = pil % memberin 1990 1991 ! chunks 1992 nb_chunks = pil % nb_chunks 1993 Allocate(parentarray_chunk(nb_chunks,nbdim,2,2)) 1994 parentarray_chunk = pil % parentarray_chunk 1995 Allocate(parentarray_chunk_decal(nb_chunks,nbdim,2,2)) 1996 parentarray_chunk_decal = pil % parentarray_chunk_decal 1997 Allocate(correction_required(nb_chunks)) 1998 correction_required = pil % correction_required 1999 Allocate(decal_chunks(nb_chunks,nbdim)) 2000 decal_chunks = pil % decal_chunks 2001 Allocate(member_chuncks(nb_chunks)) 2002 member_chuncks = pil % member_chuncks 2003 1443 2004 find_list_interp = .true. 1444 2005 exit find_loop … … 1454 2015 indmin, indmax, indminglob, indmaxglob, & 1455 2016 pttruetab, cetruetab, & 1456 memberin, nbdim & 2017 memberin, nbdim, & 2018 parentarray_chunk,parentarray_chunk_decal,decal_chunks, & 2019 correction_required,member_chuncks,nb_chunks & 1457 2020 #if defined AGRIF_MPI 1458 2021 ,indminglob2, indmaxglob2, & … … 1470 2033 integer, dimension(nbdim) :: pttruetab, cetruetab 1471 2034 logical :: memberin 2035 integer :: nb_chunks 2036 integer, dimension(:,:,:,:), allocatable :: parentarray_chunk 2037 integer, dimension(:,:,:,:), allocatable :: parentarray_chunk_decal 2038 integer, dimension(:,:),allocatable :: decal_chunks 2039 logical, dimension(:),allocatable :: correction_required 2040 logical, dimension(:),allocatable :: member_chuncks 1472 2041 #if defined AGRIF_MPI 1473 2042 integer, dimension(nbdim,2,2) :: parentarray … … 1518 2087 pil % cetruetab(1:nbdim) = cetruetab(1:nbdim) 1519 2088 2089 ! chunks 2090 pil % nb_chunks = nb_chunks 2091 allocate(pil % parentarray_chunk(nb_chunks,nbdim,2,2)) 2092 allocate(pil % parentarray_chunk_decal(nb_chunks,nbdim,2,2)) 2093 allocate(pil % correction_required(nb_chunks)) 2094 allocate(pil % decal_chunks(nb_chunks,nbdim)) 2095 allocate(pil % member_chuncks(nb_chunks)) 2096 2097 pil % parentarray_chunk = parentarray_chunk 2098 pil % parentarray_chunk_decal = parentarray_chunk_decal 2099 pil % correction_required = correction_required 2100 pil % decal_chunks = decal_chunks 2101 pil % member_chuncks = member_chuncks 2102 2103 1520 2104 parcours % suiv => list_interp 1521 2105 list_interp => parcours -
vendors/AGRIF/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modinterpbasic.F90
r5656 r13027 220 220 !CDIR ALTCODE 221 221 !CDIR NODEP 222 if (associated(agrif_external_linear_interp)) then 223 do i = 1,nc 224 y(i)=agrif_external_linear_interp(x(MAX(indparent(i,dir),1)), & 225 x(indparent(i,dir)+1),coeffparent(i,dir)) 226 enddo 227 else 222 228 do i = 1,nc 223 229 y(i) = coeffparent(i,dir) * x(MAX(indparent(i,dir),1)) + & 224 230 (1.-coeffparent(i,dir)) * x(indparent(i,dir)+1) 225 231 enddo 232 endif 226 233 !--------------------------------------------------------------------------------------------------- 227 234 end subroutine Linear1dAfterCompute -
vendors/AGRIF/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modlinktomodel.F90
r10586 r13027 50 50 end subroutine alloc_proc 51 51 ! 52 subroutine typ def_proc ( )52 subroutine typedef_proc ( ) 53 53 implicit none 54 end subroutine typ def_proc54 end subroutine typedef_proc 55 55 ! 56 56 end interface 57 57 58 58 procedure(alloc_proc) :: Agrif_Allocationcalls 59 procedure(typ def_proc) :: Agrif_probdim_modtype_def59 procedure(typedef_proc) :: Agrif_probdim_modtype_def 60 60 ! 61 61 end module Agrif_Link … … 80 80 ! Agrif_Curgrid % spaceref(1) 81 81 !=================================================================================================== 82 ! function Agrif_Parent_Irhox83 ! modify by conv. To use : var = Agrif_Parent_IRhox()84 ! Agrif_Curgrid % parent % spaceref(1)85 !===================================================================================================86 82 ! function Agrif_Rhoy 87 83 ! modify by conv. To use : var = Agrif_Rhoy() … … 96 92 ! Agrif_Curgrid % spaceref(2) 97 93 !=================================================================================================== 98 ! function Agrif_Parent_Irhoy 99 ! modify by conv. To use : var = Agrif_Parent_IRhoy() 100 ! Agrif_Curgrid % parent % spaceref(2) 94 95 101 96 !=================================================================================================== 102 97 ! function Agrif_Rhoz … … 111 106 ! modify by conv. To use : var = Agrif_Parent_IRhoz() 112 107 ! Agrif_Curgrid % spaceref(3) 113 !=================================================================================================== 114 ! function Agrif_Parent_Irhoz 115 ! modify by conv. To use : var = Agrif_Parent_IRhoz() 116 ! Agrif_Curgrid % parent % spaceref(3) 108 117 109 !=================================================================================================== 118 110 ! function Agrif_NearCommonBorderX -
vendors/AGRIF/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modmpp.F90
r5656 r13027 166 166 subroutine Get_External_Data_first ( pttruetab, cetruetab, pttruetabwhole, cetruetabwhole, & 167 167 nbdim, memberoutall, coords, sendtoproc, recvfromproc, & 168 imin, imax, imin_recv, imax_recv )168 imin, imax, imin_recv, imax_recv, bornesmin, bornesmax ) 169 169 !--------------------------------------------------------------------------------------------------- 170 170 include 'mpif.h' … … 179 179 integer, dimension(nbdim,0:Agrif_NbProcs-1), intent(out) :: imin,imax 180 180 integer, dimension(nbdim,0:Agrif_NbProcs-1), intent(out) :: imin_recv,imax_recv 181 integer, dimension(nbdim,0:Agrif_NbProcs-1), intent(in) :: bornesmin, bornesmax 181 182 ! 182 183 integer :: imintmp, imaxtmp, i, j, k, i1 … … 190 191 pttruetab2(:,Agrif_Procrank) = pttruetab(:,Agrif_Procrank) 191 192 cetruetab2(:,Agrif_Procrank) = cetruetab(:,Agrif_Procrank) 193 194 if (agrif_debug_interp) then 195 print *,'DANS Get_External_Data_first avec proc : ',Agrif_Procrank 196 do k=0,Agrif_Nbprocs-1 197 print *,'Processeur ',k 198 do i=1,nbdim 199 print *,'ptcetretab = ',i,pttruetab(i,k),cetruetab(i,k) 200 print *,'ptcetretabwhole = ',i,pttruetabwhole(i,k),cetruetabwhole(i,k) 201 enddo 202 enddo 203 endif 192 204 ! 193 205 do k = 0,Agrif_Nbprocs-1 206 if (agrif_debug_interp) then 207 print *,'Proc : ',k 208 endif 194 209 do i = 1,nbdim 210 if (agrif_debug_interp) then 211 print *,'Direction : ',i 212 endif 195 213 tochangebis = .TRUE. 196 214 DO i1 = 1,nbdim … … 203 221 ENDIF 204 222 ENDDO 223 ! Strange CASE 224 if ((pttruetab(i,k)>=pttruetab(i,Agrif_Procrank)).AND. & 225 (cetruetab(i,k)<=cetruetab(i,Agrif_Procrank))) tochangebis = .FALSE. 226 227 if (agrif_debug_interp) then 228 print *,'tochangebis= ',tochangebis 229 endif 205 230 IF (tochangebis) THEN 206 231 imin1 = max(pttruetab(i,Agrif_Procrank), pttruetab(i,k)) 207 232 imax1 = min(cetruetab(i,Agrif_Procrank), cetruetab(i,k)) 208 233 ! Always send the most interior points 209 234 if (agrif_debug_interp) then 235 print *,'imin1imax1= ',imin1,imax1 236 endif 210 237 tochange = .false. 211 238 IF (cetruetab(i,Agrif_Procrank) > cetruetab(i,k)) THEN 212 239 DO j=imin1,imax1 213 IF (( cetruetab(i,k)-j) > (j-pttruetab(i,Agrif_Procrank))) THEN240 IF ((bornesmax(i,k)-j) > (j-bornesmin(i,Agrif_Procrank))) THEN 214 241 imintmp = j+1 215 242 tochange = .TRUE. … … 228 255 IF (pttruetab(i,Agrif_Procrank) < pttruetab(i,k)) THEN 229 256 DO j=imax1,imin1,-1 230 IF ((j- pttruetab(i,k)) > (cetruetab(i,Agrif_Procrank)-j)) THEN257 IF ((j-bornesmin(i,k)) > (bornesmax(i,Agrif_Procrank)-j)) THEN 231 258 imaxtmp = j-1 232 259 tochange = .TRUE. … … 244 271 enddo 245 272 273 if (agrif_debug_interp) then 274 do k=0,Agrif_Nbprocs-1 275 print *,'Processeur ',k 276 do i=1,nbdim 277 print *,'ptcetretab2 = ',i,pttruetab2(i,k),cetruetab2(i,k) 278 enddo 279 enddo 280 endif 281 246 282 do k = 0,Agrif_NbProcs-1 247 283 ! 248 284 sendtoproc(k) = .true. 249 285 ! 286 IF ( .not. memberoutall(k) ) THEN 287 sendtoproc(k) = .false. 288 ELSE 250 289 !CDIR SHORTLOOP 251 290 do i = 1,nbdim … … 257 296 endif 258 297 enddo 259 IF ( .not. memberoutall(k) ) THEN260 sendtoproc(k) = .false.261 298 ENDIF 262 299 enddo … … 384 421 ENDIF 385 422 ! 423 if (agrif_debug_interp) then 424 print *,'PROCESSEUR = ',Agrif_Procrank 425 print *,'SENDTOPROC = ',sendtoproc(Agrif_Procrank) 426 if (sendtoproc(Agrif_Procrank)) then 427 print *,'imin imax = ',imin(:,Agrif_Procrank),imax(:,Agrif_Procrank) 428 endif 429 endif 386 430 IF (sendtoproc(Agrif_ProcRank)) THEN 387 431 call Agrif_var_copy_array(tempCextend,imin(:,Agrif_Procrank),imax(:,Agrif_Procrank), & -
vendors/AGRIF/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modtypes.F90
r12420 r13027 20 20 ! 21 21 ! 22 ! 22 ! 23 23 !> Definition of data types used in AGRIF, of several variables and parameters 24 24 ! … … 109 109 real(4), dimension(:,:,:,:,:,:), allocatable :: sarray6 110 110 !> @} 111 !> \name Arrays containing the values of the grid variables (real) 112 !> @{ 113 real, dimension(:) , pointer :: parray1 114 real, dimension(:,:) , pointer :: parray2 115 real, dimension(:,:,:) , pointer :: parray3 116 real, dimension(:,:,:,:) , pointer :: parray4 117 real, dimension(:,:,:,:,:) , pointer :: parray5 118 real, dimension(:,:,:,:,:,:), pointer :: parray6 119 !> @} 120 !> \name Arrays containing the values of the grid variables (real*8) 121 !> @{ 122 real(8), dimension(:) , pointer :: pdarray1 123 real(8), dimension(:,:) , pointer :: pdarray2 124 real(8), dimension(:,:,:) , pointer :: pdarray3 125 real(8), dimension(:,:,:,:) , pointer :: pdarray4 126 real(8), dimension(:,:,:,:,:) , pointer :: pdarray5 127 real(8), dimension(:,:,:,:,:,:), pointer :: pdarray6 128 !> @} 129 !> \name Arrays containing the values of the grid variables (real*4) 130 !> @{ 131 real(4), dimension(:) , pointer :: psarray1 132 real(4), dimension(:,:) , pointer :: psarray2 133 real(4), dimension(:,:,:) , pointer :: psarray3 134 real(4), dimension(:,:,:,:) , pointer :: psarray4 135 real(4), dimension(:,:,:,:,:) , pointer :: psarray5 136 real(4), dimension(:,:,:,:,:,:), pointer :: psarray6 137 !> @} 111 138 !> \name Arrays used to restore the values 112 139 !> @{ … … 153 180 !> \name Arrays containing the values of the grid variables (character) 154 181 !> @{ 155 character( 2400) :: carray0182 character(4000) :: carray0 156 183 character(:) , allocatable :: carrayu 157 character( 200), dimension(:) , allocatable :: carray1158 character( 200), dimension(:,:), allocatable :: carray2184 character(400), dimension(:) , allocatable :: carray1 185 character(400), dimension(:,:), allocatable :: carray2 159 186 !> @} 160 187 !--------------------------------------------------------------------------------------------------- … … 219 246 !> \name Arrays containing the values of the grid variables (logical) 220 247 !> @{ 221 logical :: larray0 248 logical :: larray0 = .FALSE. 222 249 logical, dimension(:) , allocatable :: larray1 223 250 logical, dimension(:,:) , allocatable :: larray2 … … 226 253 logical, dimension(:,:,:,:,:) , allocatable :: larray5 227 254 logical, dimension(:,:,:,:,:,:), allocatable :: larray6 228 !> @} 255 256 !> @} 257 !> \name Arrays containing the values of the grid variables (logical pointers) 258 !> @{ 259 logical, dimension(:) , pointer :: plarray1 260 logical, dimension(:,:) , pointer :: plarray2 261 logical, dimension(:,:,:) , pointer :: plarray3 262 logical, dimension(:,:,:,:) , pointer :: plarray4 263 logical, dimension(:,:,:,:,:) , pointer :: plarray5 264 logical, dimension(:,:,:,:,:,:), pointer :: plarray6 265 !> @} 266 229 267 !--------------------------------------------------------------------------------------------------- 230 268 end type Agrif_Variable_l … … 243 281 !> \name Arrays containing the values of the grid variables (integer) 244 282 !> @{ 245 integer :: iarray0 283 integer :: iarray0 = 0 246 284 integer, dimension(:) , allocatable :: iarray1 247 285 integer, dimension(:,:) , allocatable :: iarray2 … … 250 288 integer, dimension(:,:,:,:,:) , allocatable :: iarray5 251 289 integer, dimension(:,:,:,:,:,:), allocatable :: iarray6 290 291 !> @} 292 ! 293 !> \name Arrays containing the values of the grid variables (integer pointers) 294 !> @{ 295 integer, dimension(:) , pointer :: piarray1 296 integer, dimension(:,:) , pointer :: piarray2 297 integer, dimension(:,:,:) , pointer :: piarray3 298 integer, dimension(:,:,:,:) , pointer :: piarray4 299 integer, dimension(:,:,:,:,:) , pointer :: piarray5 300 integer, dimension(:,:,:,:,:,:), pointer :: piarray6 252 301 !> @} 253 302 !--------------------------------------------------------------------------------------------------- … … 274 323 logical, dimension(:), pointer :: sendtoproc2 => NULL() 275 324 logical, dimension(:), pointer :: recvfromproc1 => NULL() 276 logical, dimension(:), pointer :: recvfromproc2 => NULL() 325 logical, dimension(:), pointer :: recvfromproc2 => NULL() 277 326 #endif 327 integer :: nb_chunks 328 integer, dimension(:,:,:,:), allocatable :: parentarray_chunk 329 integer, dimension(:,:,:,:), allocatable :: parentarray_chunk_decal 330 integer, dimension(:,:),allocatable :: decal_chunks 331 logical, dimension(:),allocatable :: correction_required 332 logical, dimension(:),allocatable :: member_chuncks 278 333 !--------------------------------------------------------------------------------------------------- 279 334 end type Agrif_Interp_Loc … … 345 400 integer, parameter :: Agrif_Update_Average = 2 !< average 346 401 integer, parameter :: Agrif_Update_Full_Weighting = 3 !< full-weighting 402 integer, parameter :: Agrif_Update_Max = 4 !< Max 347 403 !> @} 348 404 !> \name Raffinement grid switches … … 375 431 real, dimension(:,:,:,:,:,:), allocatable :: parray6 376 432 ! 377 logical :: agrif_debug = .false. ! may be activaded in users subroutine for debugging purposes 433 logical :: agrif_debug = .false. ! may be activaded in users subroutine for debugging purposes 434 logical :: agrif_debug_interp = .false. ! may be activaded in users subroutine for debugging interpolations 435 logical :: agrif_debug_update = .false. ! may be activaded in users subroutine for debugging updates 378 436 379 437 ! If a grand mother grid is present … … 381 439 integer, dimension(3) :: coarse_spaceref = (/1,1,1/) 382 440 integer, dimension(3) :: coarse_timeref = (/1,1,1/) 441 442 443 ! External mapping procedure 444 Procedure(mapping), pointer :: agrif_external_mapping => NULL() 445 abstract interface 446 subroutine mapping(ndim,ptx,pty,bounds,bounds_chunks,correction_required,nb_chunks) 447 integer :: ndim, ptx, pty 448 integer,dimension(ndim,2,2) :: bounds 449 integer,dimension(:,:,:,:),allocatable :: bounds_chunks 450 logical,dimension(:),allocatable :: correction_required 451 integer :: nb_chunks 452 end subroutine mapping 453 end interface 454 455 Procedure(linear_interp), pointer :: agrif_external_linear_interp => NULL() 456 abstract interface 457 real function linear_interp(x1,x2,coeff) 458 real :: x1, x2, coeff 459 end function linear_interp 460 end interface 383 461 ! 384 462 contains -
vendors/AGRIF/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modupdate.F90
r5656 r13027 279 279 real, dimension(nbdim), intent(in) :: ds_parent !< Space steps of the parent grid 280 280 procedure() :: procname !< Data recovery procedure 281 integer, dimension(6) :: loctab_child ! Indicates if the child grid has a common border 282 ! with the root grid 283 type(Agrif_Variable), pointer :: root_var ! Variable on the root grid 281 284 ! 282 285 integer,dimension(nbdim) :: type_update ! Type of update (copy or average) … … 288 291 integer :: nb, ndir 289 292 integer :: coeffraf 290 ! 293 integer :: n 294 ! 295 root_var => child % root_var 296 loctab_child(1:nbdim) = 0 297 ! 298 do n = 1,nbdim 299 ! 300 select case(root_var % interptab(n)) 301 ! 302 case('x') ! x DIMENSION 303 ! 304 if (Agrif_Curgrid % NearRootBorder(1)) loctab_child(n) = -1 305 if (Agrif_Curgrid % DistantRootBorder(1)) loctab_child(n) = -2 306 if ((Agrif_Curgrid % NearRootBorder(1)) .AND. & 307 (Agrif_Curgrid % DistantRootBorder(1))) loctab_child(n) = -3 308 ! 309 case('y') ! y DIMENSION 310 ! 311 if (Agrif_Curgrid % NearRootBorder(2)) loctab_child(n) = -1 312 if (Agrif_Curgrid % DistantRootBorder(2)) loctab_child(n) = -2 313 if ((Agrif_Curgrid % NearRootBorder(2)) .AND. & 314 (Agrif_Curgrid % DistantRootBorder(2))) loctab_child(n) = -3 315 ! 316 case('z') ! z DIMENSION 317 ! 318 if (Agrif_Curgrid % NearRootBorder(3)) loctab_child(n) = -1 319 if (Agrif_Curgrid % DistantRootBorder(3)) loctab_child(n) = -2 320 if ((Agrif_Curgrid % NearRootBorder(3)) .AND. & 321 (Agrif_Curgrid % DistantRootBorder(3))) loctab_child(n) = -3 322 ! 323 case('N') ! No space DIMENSION 324 ! 325 loctab_child(n) = -3 326 ! 327 end select 328 ! 329 enddo 330 291 331 type_update = child % root_var % type_update(1:nbdim) 292 332 ! … … 330 370 if ( do_update(nb) ) then 331 371 do ndir = 1,2 372 if (loctab_child(nb) /= (-ndir) .AND. loctab_child(nb) /= -3) then 332 373 ptres(nb,1,ndir,nb) = indtruetab(nb,ndir,1) 333 374 ptres(nb,2,ndir,nb) = indtruetab(nb,ndir,2) … … 348 389 endif 349 390 enddo 391 endif 350 392 enddo 351 393 endif … … 355 397 if ( do_update(nb) ) then 356 398 do ndir = 1,2 399 if (loctab_child(nb) /= (-ndir) .AND. loctab_child(nb) /= -3) then 357 400 call Agrif_UpdatenD(type_update, parent, child, & 358 401 ptres(1:nbdim,1,ndir,nb),ptres(1:nbdim,2,ndir,nb), & … … 364 407 #endif 365 408 nbdim,procname,nb,ndir) 409 endif 366 410 enddo 367 411 endif … … 390 434 #endif 391 435 ! 392 integer, dimension(6), intent(in) :: type_update !< Type of update (copy or average)393 436 type(Agrif_Variable), pointer :: parent !< Variable of the parent grid 394 437 type(Agrif_Variable), pointer :: child !< Variable of the child grid 395 438 integer, intent(in) :: nbdim 439 integer, dimension(nbdim), intent(in) :: type_update !< Type of update (copy or average) 396 440 integer, dimension(nbdim), intent(in) :: pttab !< Index of the first point inside the domain 397 441 integer, dimension(nbdim), intent(in) :: petab !< Index of the first point inside the domain … … 423 467 logical :: memberin, member 424 468 integer :: nbin, ndirin 469 integer :: i, j,k,l,m 470 LOGICAL,DIMENSION(:),ALLOCATABLE :: member_chuncks 471 INTEGER,DIMENSION(:,:),ALLOCATABLE :: decal_chunks 472 INTEGER :: agrif_external_switch_index 473 INTEGER, DIMENSION(2) :: test_orientation 425 474 ! 426 475 #if defined AGRIF_MPI 427 476 ! 428 477 integer,dimension(nbdim) :: indminglob2,indmaxglob2 478 INTEGER, DIMENSION(:,:),ALLOCATABLE :: indminglob_chunks, indmaxglob_chunks 479 INTEGER, DIMENSION(:,:),ALLOCATABLE :: indminglob2_chunks,indmaxglob2_chunks 480 INTEGER, DIMENSION(:,:),ALLOCATABLE :: indminglob3_chunks,indmaxglob3_chunks 429 481 logical, dimension(0:Agrif_Nbprocs-1) :: sendtoproc1,recvfromproc1 430 482 logical, dimension(0:Agrif_Nbprocs-1) :: sendtoproc2,recvfromproc2 431 483 integer :: code, local_proc 432 integer :: i,j,k433 484 integer, dimension(nbdim,4) :: tab3 434 485 integer, dimension(nbdim,4,0:Agrif_Nbprocs-1) :: tab4 … … 444 495 type(Agrif_Variable), pointer, save :: tempP => NULL() ! Temporary parent grid variable 445 496 type(Agrif_Variable), pointer, save :: tempCextend => NULL() ! Temporary child 497 446 498 type(Agrif_Variable), pointer, save :: tempPextend => NULL() ! Temporary parent 499 type(Agrif_Variable), pointer, save :: tempPextend_chunk => NULL() ! Temporary parent 447 500 type(Agrif_Variable), pointer :: tempP_indic, tempP_average 448 501 type(Agrif_Variable), pointer :: tempC_indic … … 450 503 real :: coeff_multi 451 504 integer :: nb_dimensions 505 506 ! CHUNK (e.g. periodicity) 507 508 INTEGER :: nb_chunks 509 INTEGER, DIMENSION(:,:,:,:), ALLOCATABLE :: parentarray_chunk 510 INTEGER, DIMENSION(:,:,:,:), ALLOCATABLE :: parentarray_chunk_decal 511 INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: bounds_chunks 512 logical,dimension(:),allocatable :: correction_required 513 ! 514 452 515 ! 453 516 ! Get local lower and upper bound of the child variable … … 459 522 coords = child % root_var % coords 460 523 ! 524 461 525 call Agrif_Childbounds( nbdim, lowerbound, upperbound, pttab, petab, Agrif_Procrank, & 462 526 coords, pttruetab, cetruetab, memberin ) 527 528 if (agrif_debug_update) then 529 print *,'************CHILDBOUNDS*********************************' 530 #ifdef AGRIF_MPI 531 print *,'Processeur ',Agrif_Procrank 532 #endif 533 print *,'memberin ',memberin 534 do i = 1 , nbdim 535 print *,'Direction ',i,' indices debut: ',pttab(i),pttruetab(i) 536 print *,'Direction ',i,' indices fin : ',petab(i),cetruetab(i) 537 enddo 538 print *,'*********************************************' 539 endif 540 463 541 call Agrif_Prtbounds( nbdim, indminglob, indmaxglob, s_Parent_temp, s_Child_temp, & 464 542 s_child, ds_child, s_parent, ds_parent, & … … 469 547 ) 470 548 549 if (agrif_debug_update) then 550 print *,'************PRTBOUNDS*********************************' 551 #ifdef AGRIF_MPI 552 print *,'Processeur ',Agrif_Procrank 553 #endif 554 do i = 1 , nbdim 555 print *,'Direction ',i,' indminglob : ',indminglob(i) 556 print *,'Direction ',i,' indmaxglob : ',indmaxglob(i) 557 enddo 558 559 do i = 1 , nbdim 560 print *,'Direction ',i,' s_Parent_temp : ',s_Parent_temp(i) 561 print *,'Direction ',i,' s_Child_temp : ',s_Child_temp(i) 562 enddo 563 print *,'*********************************************' 564 endif 565 471 566 #if defined AGRIF_MPI 472 567 ! … … 476 571 nbdim, Agrif_Procrank, member) 477 572 ENDIF 573 574 if (agrif_debug_update) then 575 print *,'************GlobalToLocalBounds******************' 576 #ifdef AGRIF_MPI 577 print *,'Processeur ',Agrif_Procrank 578 #endif 579 do i = 1 , nbdim 580 print *,'Direction ',i,' childarray global : ',childarray(i,1,1),childarray(i,2,1) 581 print *,'Direction ',i,' childarray local : ',childarray(i,1,2),childarray(i,2,2) 582 enddo 583 584 print *,'*********************************************' 585 endif 478 586 479 587 call Agrif_Prtbounds(nbdim, indmin, indmax, & … … 483 591 posvar, type_update, do_update, & 484 592 pttruetabwhole, cetruetabwhole) 593 594 if (agrif_debug_update) then 595 print *,'************PRTBOUNDS II *********************************' 596 #ifdef AGRIF_MPI 597 print *,'Processeur ',Agrif_Procrank 598 #endif 599 do i = 1 , nbdim 600 print *,'Direction ',i,' indmin : ',indmin(i) 601 print *,'Direction ',i,' indmax : ',indmax(i) 602 enddo 603 604 do i = 1 , nbdim 605 print *,'Direction ',i,' s_Parent_temp : ',s_Parent_temp(i) 606 print *,'Direction ',i,' s_Child_temp : ',s_Child_temp(i) 607 enddo 608 print *,'*********************************************' 609 endif 485 610 ! 486 611 #else … … 582 707 nbdim, memberinall, coords, & 583 708 sendtoproc1,recvfromproc1, & 584 tab4t(:,:,5),tab4t(:,:,6),tab4t(:,:,7),tab4t(:,:,8)) 709 tab4t(:,:,5),tab4t(:,:,6),tab4t(:,:,7),tab4t(:,:,8), & 710 tab4t(:,:,1),tab4t(:,:,2)) 585 711 endif 586 712 … … 610 736 s_Child_temp(1), s_Parent_temp(1), & 611 737 ds_child(1), ds_parent(1) ) 612 738 613 739 IF (Agrif_UseSpecialValueInUpdate) THEN 614 740 allocate(tempC_indic) … … 638 764 enddo 639 765 ENDIF 640 766 641 767 WHERE (tempCextend%array1 == Agrif_SpecialValueFineGrid) 642 768 tempC_indic%array1 = 0. … … 644 770 tempC_indic%array1 = 1. 645 771 END WHERE 646 772 647 773 Agrif_UseSpecialValueInUpdate = .FALSE. 648 774 Agrif_Update_Weights = .TRUE. 649 775 650 776 call Agrif_Update_1D_Recursive( type_update_temp(1), & 651 777 tempP_indic%array1, & … … 675 801 END WHERE 676 802 ENDIF 677 803 678 804 deallocate(tempP_indic%array1) 679 805 deallocate(tempC_indic%array1) … … 685 811 ENDIF 686 812 ENDIF 687 813 688 814 endif 689 815 if ( nbdim == 2 ) then … … 701 827 call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array2),ubound(tempCextend%array2),nbdim) 702 828 call Agrif_array_allocate(tempP_indic,lbound(tempP%array2),ubound(tempP%array2),nbdim) 703 829 704 830 compute_average = .FALSE. 705 831 type_update_temp(1:nbdim) = type_update(1:nbdim) … … 723 849 enddo 724 850 ENDIF 725 851 726 852 WHERE (tempCextend%array2 == Agrif_SpecialValueFineGrid) 727 853 tempC_indic%array2 = 0. … … 729 855 tempC_indic%array2 = 1. 730 856 END WHERE 731 857 732 858 Agrif_UseSpecialValueInUpdate = .FALSE. 733 859 Agrif_Update_Weights = .TRUE. 734 860 735 861 call Agrif_Update_2D_Recursive( type_update_temp(1:2), & 736 862 tempP_indic%array2, & … … 760 886 END WHERE 761 887 ENDIF 762 888 763 889 deallocate(tempP_indic%array2) 764 890 deallocate(tempC_indic%array2) … … 770 896 ENDIF 771 897 ENDIF 772 898 773 899 endif 774 900 if ( nbdim == 3 ) then … … 780 906 s_Child_temp(1:3), s_Parent_temp(1:3), & 781 907 ds_child(1:3), ds_parent(1:3) ) 782 908 783 909 IF (Agrif_UseSpecialValueInUpdate) THEN 784 910 allocate(tempC_indic) … … 808 934 enddo 809 935 ENDIF 810 936 811 937 WHERE (tempCextend%array3 == Agrif_SpecialValueFineGrid) 812 938 tempC_indic%array3 = 0. … … 814 940 tempC_indic%array3 = 1. 815 941 END WHERE 816 942 817 943 Agrif_UseSpecialValueInUpdate = .FALSE. 818 944 Agrif_Update_Weights = .TRUE. 819 945 820 946 call Agrif_Update_3D_Recursive( type_update_temp(1:3), & 821 947 tempP_indic%array3, & … … 845 971 END WHERE 846 972 ENDIF 847 973 848 974 deallocate(tempP_indic%array3) 849 975 deallocate(tempC_indic%array3) … … 855 981 ENDIF 856 982 ENDIF 857 983 858 984 endif 859 985 if ( nbdim == 4 ) then … … 865 991 s_Child_temp(1:4), s_Parent_temp(1:4), & 866 992 ds_child(1:4), ds_parent(1:4) ) 867 993 868 994 IF (Agrif_UseSpecialValueInUpdate) THEN 869 995 870 996 allocate(tempC_indic) 871 997 allocate(tempP_indic) 872 998 call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array4),ubound(tempCextend%array4),nbdim) 873 999 call Agrif_array_allocate(tempP_indic,lbound(tempP%array4),ubound(tempP%array4),nbdim) 874 1000 875 1001 compute_average = .FALSE. 876 1002 type_update_temp(1:nbdim) = type_update(1:nbdim) … … 894 1020 enddo 895 1021 ENDIF 896 1022 897 1023 WHERE (tempCextend%array4 == Agrif_SpecialValueFineGrid) 898 1024 tempC_indic%array4 = 0. … … 900 1026 tempC_indic%array4 = 1. 901 1027 END WHERE 902 1028 903 1029 Agrif_UseSpecialValueInUpdate = .FALSE. 904 1030 Agrif_Update_Weights = .TRUE. 905 1031 906 1032 call Agrif_Update_4D_Recursive( type_update_temp(1:4), & 907 1033 tempP_indic%array4, & … … 914 1040 Agrif_UseSpecialValueInUpdate = .TRUE. 915 1041 Agrif_Update_Weights = .FALSE. 916 1042 917 1043 IF (compute_average) THEN 918 1044 WHERE (tempP_indic%array4 == 0.) … … 940 1066 ENDIF 941 1067 ENDIF 942 1068 943 1069 endif 944 1070 if ( nbdim == 5 ) then … … 950 1076 s_Child_temp(1:5), s_Parent_temp(1:5), & 951 1077 ds_child(1:5), ds_parent(1:5) ) 952 1078 953 1079 IF (Agrif_UseSpecialValueInUpdate) THEN 954 1080 allocate(tempC_indic) … … 978 1104 enddo 979 1105 ENDIF 980 1106 981 1107 WHERE (tempCextend%array5 == Agrif_SpecialValueFineGrid) 982 1108 tempC_indic%array5 = 0. … … 984 1110 tempC_indic%array5 = 1. 985 1111 END WHERE 986 1112 987 1113 Agrif_UseSpecialValueInUpdate = .FALSE. 988 1114 Agrif_Update_Weights = .TRUE. 989 1115 990 1116 call Agrif_Update_5D_Recursive( type_update_temp(1:5), & 991 1117 tempP_indic%array5, & … … 1015 1141 END WHERE 1016 1142 ENDIF 1017 1143 1018 1144 deallocate(tempP_indic%array5) 1019 1145 deallocate(tempC_indic%array5) … … 1025 1151 ENDIF 1026 1152 ENDIF 1027 1153 1028 1154 endif 1029 1155 if ( nbdim == 6 ) then … … 1080 1206 END WHERE 1081 1207 ENDIF 1082 1208 1083 1209 Agrif_UseSpecialValueInUpdate = .FALSE. 1084 1210 Agrif_Update_Weights = .TRUE. 1085 1211 1086 1212 call Agrif_Update_6D_Recursive( type_update_temp(1:6), & 1087 1213 tempP_indic%array6, & … … 1094 1220 Agrif_UseSpecialValueInUpdate = .TRUE. 1095 1221 Agrif_Update_Weights = .FALSE. 1096 1222 1097 1223 WHERE (tempP_indic%array6 == 0.) 1098 1224 tempP%array6 = Agrif_SpecialValueFineGrid … … 1100 1226 tempP%array6 = tempP%array6 /tempP_indic%array6 1101 1227 END WHERE 1102 1228 1103 1229 deallocate(tempP_indic%array6) 1104 1230 deallocate(tempC_indic%array6) … … 1116 1242 ENDIF 1117 1243 1244 if (agrif_debug_update .and. nbdim==2) then 1245 print *,'MINMAXUPDATE = ',minval(tempP%array2),maxval(tempP%array2) 1246 endif 1247 1118 1248 #if defined AGRIF_MPI 1119 1249 local_proc = Agrif_Procrank 1120 1250 call Agrif_get_var_bounds_array(parent,lowerbound,upperbound,nbdim) 1121 1251 call Agrif_ChildGrid_to_ParentGrid() 1122 call Agrif_Childbounds(nbdim, lowerbound, upperbound, & 1123 indminglob, indmaxglob, local_proc, coords, & 1124 indminglob2, indmaxglob2, member) 1125 ! 1126 IF (member) THEN 1127 call Agrif_GlobalToLocalBounds(parentarray, lowerbound, upperbound, & 1128 indminglob2, indmaxglob2, coords, & 1129 nbdim, local_proc, member) 1130 ENDIF 1131 1132 call Agrif_ParentGrid_to_ChildGrid() 1252 1253 parentarray(:,1,1) = indminglob 1254 parentarray(:,2,1) = indmaxglob 1255 parentarray(:,1,2) = indminglob 1256 parentarray(:,2,2) = indmaxglob 1257 if (associated(agrif_external_mapping)) then 1258 call agrif_external_mapping(nbdim,child%root_var % posvar(1),child%root_var % posvar(2), & 1259 parentarray,parentarray_chunk,correction_required,nb_chunks) 1260 allocate(decal_chunks(nb_chunks,nbdim)) 1261 do i=1,nb_chunks 1262 decal_chunks(i,:)=parentarray_chunk(i,:,1,1)-parentarray_chunk(i,:,1,2) 1263 enddo 1264 else 1265 nb_chunks=1 1266 allocate(correction_required(nb_chunks)) 1267 correction_required=.FALSE. 1268 allocate(parentarray_chunk(nb_chunks,nbdim,2,2)) 1269 parentarray_chunk(1,:,:,:)=parentarray 1270 allocate(decal_chunks(nb_chunks,nbdim)) 1271 decal_chunks=0 1272 endif 1273 if (agrif_debug_update) then 1274 print *,'AVANT PARENTCHILDBOUNDS' 1275 print *,'nombre de chunks ',nb_chunks 1276 do i=1,nb_chunks 1277 print *,'CHUNK Number : ',i 1278 do j=1,nbdim 1279 print *,'Direction ',j 1280 print *,'MIN MAX (2) = ',parentarray_chunk(i,j,1,2),parentarray_chunk(i,j,2,2) 1281 print *,'MIN MAX (1) = ',parentarray_chunk(i,j,1,1),parentarray_chunk(i,j,2,1) 1282 enddo 1283 enddo 1284 print *,'APRES PARENTCHILDBOUNDS' 1285 endif 1286 1287 allocate(indminglob_chunks(nb_chunks,nbdim)) 1288 allocate(indmaxglob_chunks(nb_chunks,nbdim)) 1289 allocate(indminglob2_chunks(nb_chunks,nbdim)) 1290 allocate(indmaxglob2_chunks(nb_chunks,nbdim)) 1291 allocate(indminglob3_chunks(nb_chunks,nbdim)) 1292 allocate(indmaxglob3_chunks(nb_chunks,nbdim)) 1293 allocate(member_chuncks(nb_chunks)) 1294 1295 do i=1,nb_chunks 1296 indminglob_chunks(i,:) = parentarray_chunk(i,:,1,2) 1297 indmaxglob_chunks(i,:) = parentarray_chunk(i,:,2,2) 1298 enddo 1299 1300 do i=1,nb_chunks 1301 call Agrif_Childbounds(nbdim,lowerbound,upperbound, & 1302 indminglob_chunks(i,:),indmaxglob_chunks(i,:), local_proc, coords, & 1303 indminglob2_chunks(i,:),indmaxglob2_chunks(i,:),member_chuncks(i)) 1304 enddo 1305 1306 if (agrif_debug_update) then 1307 print *,'************CHILDBOUNDSPARENTMPI*********************************' 1308 #ifdef AGRIF_MPI 1309 print *,'Processeur ',Agrif_Procrank 1310 #endif 1311 do j=1,nb_chunks 1312 print *,'Chunk number ',j 1313 1314 do i = 1 , nbdim 1315 print *,'Direction ',i,' indices debut: ',indminglob_chunks(j,i),indminglob2_chunks(j,i) 1316 print *,'Direction ',i,' indices fin : ',indmaxglob_chunks(j,i),indmaxglob2_chunks(j,i) 1317 enddo 1318 enddo 1319 print *,'*********************************************' 1320 endif 1321 1322 allocate(parentarray_chunk_decal(nb_chunks,nbdim,2,2)) 1323 do j=1,nb_chunks 1324 if (agrif_debug_update) print *,'CHUNK = ',j 1325 if (member_chuncks(j)) then 1326 ! call Agrif_GlobalToLocalBounds(parentarray_chunk(j,:,:,:), & 1327 ! lowerbound, upperbound, & 1328 ! indminglob2_chunks(j,:), indmaxglob2_chunks(j,:), coords, & 1329 ! nbdim, local_proc, member_chuncks(j),check_perio=.TRUE.) 1330 1331 call Agrif_GlobalToLocalBounds(parentarray_chunk(j,:,:,:), & 1332 lowerbound, upperbound, & 1333 indminglob2_chunks(j,:), indmaxglob2_chunks(j,:), coords, & 1334 nbdim, local_proc, member_chuncks(j)) 1335 1336 if (correction_required(j)) then 1337 do i=1,2 1338 test_orientation(1)=agrif_external_switch_index(child%root_var % posvar(1),child%root_var % posvar(2), & 1339 parentarray_chunk(j,i,1,1),i) 1340 test_orientation(2)=agrif_external_switch_index(child%root_var % posvar(1),child%root_var % posvar(2), & 1341 parentarray_chunk(j,i,2,1),i) 1342 parentarray_chunk_decal(j,i,1,1)=minval(test_orientation) 1343 parentarray_chunk_decal(j,i,2,1)=maxval(test_orientation) 1344 enddo 1345 do i=3,nbdim 1346 parentarray_chunk_decal(j,i,:,1) = parentarray_chunk(j,i,:,1)+decal_chunks(j,i) 1347 enddo 1348 else 1349 do i=1,nbdim 1350 parentarray_chunk_decal(j,i,:,1) = parentarray_chunk(j,i,:,1)+decal_chunks(j,i) 1351 enddo 1352 endif 1353 1354 if (agrif_debug_update) then 1355 do i=1,nbdim 1356 print *,'parentarray = ',i,parentarray_chunk(j,i,1,1),parentarray_chunk(j,i,2,1), & 1357 parentarray_chunk(j,i,1,2),parentarray_chunk(j,i,2,2) 1358 print *,'parentarraydecal = ',i,parentarray_chunk_decal(j,i,1,1),parentarray_chunk_decal(j,i,2,1) 1359 enddo 1360 endif 1361 endif 1362 enddo 1363 1364 ! call Agrif_Childbounds(nbdim, lowerbound, upperbound, & 1365 ! indminglob, indmaxglob, local_proc, coords, & 1366 ! indminglob2, indmaxglob2, member) 1367 1368 ! if (agrif_debug_update) then 1369 ! print *,'************CHILDBOUNDS PARENT*********************************' 1370 ! #ifdef AGRIF_MPI 1371 ! print *,'Processeur ',Agrif_Procrank 1372 ! #endif 1373 ! print *,'member ',member 1374 ! do i = 1 , nbdim 1375 ! print *,'Direction ',i,' indminglob2 : ',indminglob2(i) 1376 ! print *,'Direction ',i,' indmaxglob2 : ',indmaxglob2(i) 1377 ! enddo 1378 ! print *,'*********************************************' 1379 ! endif 1380 ! 1381 ! IF (member) THEN 1382 ! call Agrif_GlobalToLocalBounds(parentarray, lowerbound, upperbound, & 1383 ! indminglob2, indmaxglob2, coords, & 1384 ! nbdim, local_proc, member,check_perio=.TRUE.) 1385 ! ENDIF 1386 1387 ! if (agrif_debug_update) then 1388 ! print *,'************GlobalToLocalBounds II******************' 1389 ! #ifdef AGRIF_MPI 1390 ! print *,'Processeur ',Agrif_Procrank 1391 ! #endif 1392 ! do i = 1 , nbdim 1393 ! print *,'Direction ',i,' parentarray global : ',parentarray(i,1,1),parentarray(i,2,1) 1394 ! print *,'Direction ',i,' parentarray local : ',parentarray(i,1,2),parentarray(i,2,2) 1395 ! enddo 1396 1397 ! print *,'*********************************************' 1398 ! endif 1399 1400 1401 parentarray(:,1,:)=Huge(1) 1402 parentarray(:,2,:)=-Huge(1) 1403 indminglob2=Huge(1) 1404 indmaxglob2=-Huge(1) 1405 member = .FALSE. 1406 do j=1,nb_chunks 1407 if (member_chuncks(j)) then 1408 do i=1,nbdim 1409 parentarray(i,1,1) = min(parentarray(i,1,1),parentarray_chunk_decal(j,i,1,1)) 1410 parentarray(i,1,2) = min(parentarray(i,1,2),parentarray_chunk(j,i,1,2)) 1411 parentarray(i,2,1) = max(parentarray(i,2,1),parentarray_chunk_decal(j,i,2,1)) 1412 parentarray(i,2,2) = max(parentarray(i,2,2),parentarray_chunk(j,i,2,2)) 1413 enddo 1414 1415 if (correction_required(j)) then 1416 do i=1,2 1417 test_orientation(1)=agrif_external_switch_index(child%root_var % posvar(1),child%root_var % posvar(2), & 1418 indminglob2_chunks(j,i),i) 1419 test_orientation(2)=agrif_external_switch_index(child%root_var % posvar(1),child%root_var % posvar(2), & 1420 indmaxglob2_chunks(j,i),i) 1421 indminglob2(i)=min(indminglob2(i),minval(test_orientation)) 1422 indmaxglob2(i)=max(indmaxglob2(i),maxval(test_orientation)) 1423 enddo 1424 1425 do i=3,nbdim 1426 indminglob2(i)=min(indminglob2(i),indminglob2_chunks(j,i)+decal_chunks(j,i)) 1427 indmaxglob2(i)=max(indmaxglob2(i),indmaxglob2_chunks(j,i)+decal_chunks(j,i)) 1428 enddo 1429 else 1430 do i=1,nbdim 1431 indminglob2(i)=min(indminglob2(i),indminglob2_chunks(j,i)+decal_chunks(j,i)) 1432 indmaxglob2(i)=max(indmaxglob2(i),indmaxglob2_chunks(j,i)+decal_chunks(j,i)) 1433 enddo 1434 endif 1435 1436 member = .TRUE. 1437 endif 1438 enddo 1439 1440 call Agrif_ParentGrid_to_ChildGrid() 1441 1442 if (agrif_debug_update) then 1443 print *,'************ FINAL PARENTARRAY *****************' 1444 #ifdef AGRIF_MPI 1445 print *,'Processeur ',Agrif_Procrank,' MEMBER = ',member 1446 do i=1,nbdim 1447 print *,'Direction ',i,' indices debut = ',parentarray(i,1,1),parentarray(i,1,2) 1448 print *,'Direction ',i,' indices fin = ',parentarray(i,2,1),parentarray(i,2,2) 1449 enddo 1450 #endif 1451 endif 1452 1453 if (agrif_debug_update) then 1454 print *,'************ FINAL INDMINGLOB *****************' 1455 #ifdef AGRIF_MPI 1456 print *,'Processeur ',Agrif_Procrank,' MEMBER = ',member 1457 do i=1,nbdim 1458 print *,'Direction ',i,' indices debut = ',indminglob2(i) 1459 print *,'Direction ',i,' indices fin = ',indmaxglob2(i) 1460 enddo 1461 #endif 1462 endif 1133 1463 1134 1464 if (.not.find_list_update) then … … 1154 1484 nbdim, memberinall2, coords, & 1155 1485 sendtoproc2, recvfromproc2, & 1156 tab5t(:,:,5),tab5t(:,:,6),tab5t(:,:,7),tab5t(:,:,8)) 1486 tab5t(:,:,5),tab5t(:,:,6),tab5t(:,:,7),tab5t(:,:,8), & 1487 tab5t(:,:,1),tab5t(:,:,2)) 1157 1488 1158 1489 call Agrif_Addto_list_update(child%list_update,pttab,petab,lb_child,lb_parent, & … … 1171 1502 parentarray(:,1,2) = indmin 1172 1503 parentarray(:,2,2) = indmax 1504 1505 if (associated(agrif_external_mapping)) then 1506 call Agrif_ChildGrid_to_ParentGrid() 1507 call agrif_external_mapping(nbdim,child%root_var % posvar(1),child%root_var % posvar(2), & 1508 parentarray,parentarray_chunk,correction_required,nb_chunks) 1509 call Agrif_ParentGrid_to_ChildGrid() 1510 allocate(decal_chunks(nb_chunks,nbdim)) 1511 do i=1,nb_chunks 1512 decal_chunks(i,:)=parentarray_chunk(i,:,1,1)-parentarray_chunk(i,:,1,2) 1513 enddo 1514 else 1515 nb_chunks=1 1516 allocate(correction_required(nb_chunks)) 1517 correction_required=.FALSE. 1518 allocate(parentarray_chunk(nb_chunks,nbdim,2,2)) 1519 parentarray_chunk(1,:,:,:)=parentarray 1520 endif 1521 if (agrif_debug_update) then 1522 print *,'AVANT PARENTCHILDBOUNDS' 1523 print *,'nombre de chunks ',nb_chunks 1524 do i=1,nb_chunks 1525 print *,'CHUNK Number : ',i 1526 do j=1,nbdim 1527 print *,'Direction ',j 1528 print *,'MIN MAX (2) = ',parentarray_chunk(i,j,1,2),parentarray_chunk(i,j,2,2) 1529 print *,'MIN MAX (1) = ',parentarray_chunk(i,j,1,1),parentarray_chunk(i,j,2,1) 1530 enddo 1531 enddo 1532 print *,'APRES PARENTCHILDBOUNDS' 1533 endif 1534 allocate(member_chuncks(nb_chunks)) 1535 allocate(parentarray_chunk_decal(nb_chunks,nbdim,2,2)) 1536 member_chuncks = .TRUE. 1537 member = .TRUE. 1538 do j=1,nb_chunks 1539 if (agrif_debug_update) print *,'CHUNK = ',j 1540 if (member_chuncks(j)) then 1541 do i=1,nbdim 1542 parentarray_chunk_decal(j,i,:,1) = parentarray_chunk(j,i,:,1) !+decal_chunks(j,i) 1543 enddo 1544 if (agrif_debug_update) then 1545 do i=1,nbdim 1546 print *,'parentarray = ',i,parentarray_chunk(j,i,1,1),parentarray_chunk(j,i,2,1), & 1547 parentarray_chunk(j,i,1,2),parentarray_chunk(j,i,2,2) 1548 print *,'parentarraydecal = ',i,parentarray_chunk_decal(j,i,1,1),parentarray_chunk_decal(j,i,2,1) 1549 enddo 1550 endif 1551 endif 1552 enddo 1553 1173 1554 member = .TRUE. 1174 1555 #endif 1556 1557 if (agrif_debug_update .and. nbdim==2) then 1558 print *,'MINMAXUPDATEEXTND = ',minval(tempPextend%array2),maxval(tempPextend%array2) 1559 endif 1175 1560 ! 1176 1561 ! Special values on the child grid … … 1230 1615 endif 1231 1616 ! 1232 IF (member) THEN 1617 1233 1618 1234 1619 call Agrif_ChildGrid_to_ParentGrid() 1620 1621 if (nb_chunks > 1) then 1622 allocate(tempPextend_chunk) 1623 SELECT CASE(nbdim) 1624 CASE(1) 1625 call Agrif_array_allocate(tempPextend_chunk,lbound(tempPextend%array1),ubound(tempPextend%array1),nbdim) 1626 CASE(2) 1627 call Agrif_array_allocate(tempPextend_chunk,lbound(tempPextend%array2),ubound(tempPextend%array2),nbdim) 1628 CASE(3) 1629 call Agrif_array_allocate(tempPextend_chunk,lbound(tempPextend%array3),ubound(tempPextend%array3),nbdim) 1630 CASE(4) 1631 call Agrif_array_allocate(tempPextend_chunk,lbound(tempPextend%array4),ubound(tempPextend%array4),nbdim) 1632 CASE(5) 1633 call Agrif_array_allocate(tempPextend_chunk,lbound(tempPextend%array5),ubound(tempPextend%array5),nbdim) 1634 CASE(6) 1635 call Agrif_array_allocate(tempPextend_chunk,lbound(tempPextend%array6),ubound(tempPextend%array6),nbdim) 1636 END SELECT 1637 else 1638 tempPextend_chunk => tempPextend 1639 endif 1640 1641 do i=1,nb_chunks 1642 1643 if (member_chuncks(i)) then 1644 1645 if (nb_chunks > 1) then 1646 call Agrif_var_copy_array (tempPextend_chunk, parentarray_chunk_decal(i,:,1,1), parentarray_chunk_decal(i,:,2,1), & 1647 tempPextend, parentarray_chunk_decal(i,:,1,1), parentarray_chunk_decal(i,:,2,1), nbdim ) 1648 endif 1235 1649 ! 1236 1650 SELECT CASE(nbdim) 1237 1651 CASE(1) 1238 call procname( tempPextend % array1( & 1239 parentarray(1,1,1):parentarray(1,2,1)), & 1240 parentarray(1,1,2),parentarray(1,2,2),.FALSE.,nbin,ndirin) 1652 ! call procname( tempPextend % array1( & 1653 ! parentarray(1,1,1):parentarray(1,2,1)), & 1654 ! parentarray(1,1,2),parentarray(1,2,2),.FALSE.,nbin,ndirin) 1655 1656 call procname(tempPextend_chunk%array1(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1)), & 1657 parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2),.FALSE.,nbin,ndirin) 1658 1241 1659 CASE(2) 1242 call procname( tempPextend % array2( & 1243 parentarray(1,1,1):parentarray(1,2,1), & 1244 parentarray(2,1,1):parentarray(2,2,1)), & 1245 parentarray(1,1,2),parentarray(1,2,2), & 1246 parentarray(2,1,2),parentarray(2,2,2),.FALSE.,nbin,ndirin) 1660 1661 if (correction_required(i)) then 1662 call correct_field(tempPextend_chunk%array2(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 1663 parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1)), & 1664 parentarray_chunk_decal(i,1,1,1),parentarray_chunk_decal(i,1,2,1), & 1665 parentarray_chunk_decal(i,2,1,1),parentarray_chunk_decal(i,2,2,1)) 1666 endif 1667 1668 call procname(tempPextend_chunk%array2(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 1669 parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1)), & 1670 parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2), & 1671 parentarray_chunk(i,2,1,2),parentarray_chunk(i,2,2,2),.FALSE.,nbin,ndirin) 1672 1247 1673 CASE(3) 1248 call procname( tempPextend % array3( & 1249 parentarray(1,1,1):parentarray(1,2,1), & 1250 parentarray(2,1,1):parentarray(2,2,1), & 1251 parentarray(3,1,1):parentarray(3,2,1)), & 1252 parentarray(1,1,2),parentarray(1,2,2), & 1253 parentarray(2,1,2),parentarray(2,2,2), & 1254 parentarray(3,1,2),parentarray(3,2,2),.FALSE.,nbin,ndirin) 1674 1675 if (correction_required(i)) then 1676 do k=parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2) 1677 call correct_field(tempPextend_chunk%array3(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 1678 parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1),k), & 1679 parentarray_chunk_decal(i,1,1,1),parentarray_chunk_decal(i,1,2,1), & 1680 parentarray_chunk_decal(i,2,1,1),parentarray_chunk_decal(i,2,2,1)) 1681 enddo 1682 endif 1683 1684 call procname(tempPextend_chunk%array3(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 1685 parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1), & 1686 parentarray_chunk_decal(i,3,1,1):parentarray_chunk_decal(i,3,2,1)), & 1687 parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2), & 1688 parentarray_chunk(i,2,1,2),parentarray_chunk(i,2,2,2), & 1689 parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2),.FALSE.,nbin,ndirin) 1690 1691 1692 1693 1255 1694 CASE(4) 1256 call procname( tempPextend % array4( & 1257 parentarray(1,1,1):parentarray(1,2,1), & 1258 parentarray(2,1,1):parentarray(2,2,1), & 1259 parentarray(3,1,1):parentarray(3,2,1), & 1260 parentarray(4,1,1):parentarray(4,2,1)), & 1261 parentarray(1,1,2),parentarray(1,2,2), & 1262 parentarray(2,1,2),parentarray(2,2,2), & 1263 parentarray(3,1,2),parentarray(3,2,2), & 1264 parentarray(4,1,2),parentarray(4,2,2),.FALSE.,nbin,ndirin) 1695 1696 if (correction_required(i)) then 1697 do l=parentarray_chunk(i,4,1,2),parentarray_chunk(i,4,2,2) 1698 do k=parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2) 1699 call correct_field(tempPextend_chunk%array4(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 1700 parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1),k,l), & 1701 parentarray_chunk_decal(i,1,1,1),parentarray_chunk_decal(i,1,2,1), & 1702 parentarray_chunk_decal(i,2,1,1),parentarray_chunk_decal(i,2,2,1)) 1703 enddo 1704 enddo 1705 endif 1706 1707 call procname(tempPextend_chunk%array4(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 1708 parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1), & 1709 parentarray_chunk_decal(i,3,1,1):parentarray_chunk_decal(i,3,2,1), & 1710 parentarray_chunk_decal(i,4,1,1):parentarray_chunk_decal(i,4,2,1)), & 1711 parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2), & 1712 parentarray_chunk(i,2,1,2),parentarray_chunk(i,2,2,2), & 1713 parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2), & 1714 parentarray_chunk(i,4,1,2),parentarray_chunk(i,4,2,2),.FALSE.,nbin,ndirin) 1715 1265 1716 CASE(5) 1266 call procname( tempPextend % array5( & 1267 parentarray(1,1,1):parentarray(1,2,1), & 1268 parentarray(2,1,1):parentarray(2,2,1), & 1269 parentarray(3,1,1):parentarray(3,2,1), & 1270 parentarray(4,1,1):parentarray(4,2,1), & 1271 parentarray(5,1,1):parentarray(5,2,1)), & 1272 parentarray(1,1,2),parentarray(1,2,2), & 1273 parentarray(2,1,2),parentarray(2,2,2), & 1274 parentarray(3,1,2),parentarray(3,2,2), & 1275 parentarray(4,1,2),parentarray(4,2,2), & 1276 parentarray(5,1,2),parentarray(5,2,2),.FALSE.,nbin,ndirin) 1717 1718 if (correction_required(i)) then 1719 do m=parentarray_chunk(i,5,1,2),parentarray_chunk(i,5,2,2) 1720 do l=parentarray_chunk(i,4,1,2),parentarray_chunk(i,4,2,2) 1721 do k=parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2) 1722 call correct_field(tempPextend_chunk%array5(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 1723 parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1),k,l,m), & 1724 parentarray_chunk_decal(i,1,1,1),parentarray_chunk_decal(i,1,2,1), & 1725 parentarray_chunk_decal(i,2,1,1),parentarray_chunk_decal(i,2,2,1)) 1726 enddo 1727 enddo 1728 enddo 1729 endif 1730 1731 call procname(tempPextend_chunk%array5(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 1732 parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1), & 1733 parentarray_chunk_decal(i,3,1,1):parentarray_chunk_decal(i,3,2,1), & 1734 parentarray_chunk_decal(i,4,1,1):parentarray_chunk_decal(i,4,2,1), & 1735 parentarray_chunk_decal(i,5,1,1):parentarray_chunk_decal(i,5,2,1)), & 1736 parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2), & 1737 parentarray_chunk(i,2,1,2),parentarray_chunk(i,2,2,2), & 1738 parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2), & 1739 parentarray_chunk(i,4,1,2),parentarray_chunk(i,4,2,2), & 1740 parentarray_chunk(i,5,1,2),parentarray_chunk(i,5,2,2),.FALSE.,nbin,ndirin) 1741 1277 1742 CASE(6) 1278 call procname( tempPextend % array6( & 1279 parentarray(1,1,1):parentarray(1,2,1), & 1280 parentarray(2,1,1):parentarray(2,2,1), & 1281 parentarray(3,1,1):parentarray(3,2,1), & 1282 parentarray(4,1,1):parentarray(4,2,1), & 1283 parentarray(5,1,1):parentarray(5,2,1), & 1284 parentarray(6,1,1):parentarray(6,2,1)), & 1285 parentarray(1,1,2),parentarray(1,2,2), & 1286 parentarray(2,1,2),parentarray(2,2,2), & 1287 parentarray(3,1,2),parentarray(3,2,2), & 1288 parentarray(4,1,2),parentarray(4,2,2), & 1289 parentarray(5,1,2),parentarray(5,2,2), & 1290 parentarray(6,1,2),parentarray(6,2,2),.FALSE.,nbin,ndirin) 1743 1744 call procname(tempPextend_chunk%array6(parentarray_chunk_decal(i,1,1,1):parentarray_chunk_decal(i,1,2,1), & 1745 parentarray_chunk_decal(i,2,1,1):parentarray_chunk_decal(i,2,2,1), & 1746 parentarray_chunk_decal(i,3,1,1):parentarray_chunk_decal(i,3,2,1), & 1747 parentarray_chunk_decal(i,4,1,1):parentarray_chunk_decal(i,4,2,1), & 1748 parentarray_chunk_decal(i,5,1,1):parentarray_chunk_decal(i,5,2,1), & 1749 parentarray_chunk_decal(i,6,1,1):parentarray_chunk_decal(i,6,2,1)), & 1750 parentarray_chunk(i,1,1,2),parentarray_chunk(i,1,2,2), & 1751 parentarray_chunk(i,2,1,2),parentarray_chunk(i,2,2,2), & 1752 parentarray_chunk(i,3,1,2),parentarray_chunk(i,3,2,2), & 1753 parentarray_chunk(i,4,1,2),parentarray_chunk(i,4,2,2), & 1754 parentarray_chunk(i,5,1,2),parentarray_chunk(i,5,2,2),& 1755 parentarray_chunk(i,6,1,2),parentarray_chunk(i,6,2,2),.FALSE.,nbin,ndirin) 1756 1291 1757 END SELECT 1758 ENDIF 1759 enddo ! enddo i=1,nb_chunks 1760 1761 if (nb_chunks > 1) then 1762 call Agrif_array_deallocate(tempPextend_chunk,nbdim) 1763 deallocate(tempPextend_chunk) 1764 endif 1292 1765 ! 1293 1766 call Agrif_ParentGrid_to_ChildGrid() 1294 1767 ! 1295 call Agrif_array_deallocate(tempPextend,nbdim)1296 ! 1297 ENDIF 1768 if (ANY(member_chuncks)) call Agrif_array_deallocate(tempPextend,nbdim) 1769 ! 1770 1298 1771 ! 1299 1772 #if defined AGRIF_MPI … … 1355 1828 IF ( do_update(i) ) THEN 1356 1829 IF (posvar(i) == 1) THEN 1357 IF (type_update(i) == Agrif_Update_Average) THEN1830 IF ((type_update(i) == Agrif_Update_Average).OR.(type_update(i) == Agrif_Update_Max)) THEN 1358 1831 positionmin = positionmin - ds_parent(i)/2. 1359 1832 ELSE IF (type_update(i) == Agrif_Update_Full_Weighting) THEN … … 1381 1854 IF ( do_update(i) ) THEN 1382 1855 IF (posvar(i) == 1) THEN 1383 IF (type_update(i) == Agrif_Update_Average) THEN1856 IF ((type_update(i) == Agrif_Update_Average).OR.(type_update(i) == Agrif_Update_Max)) THEN 1384 1857 positionmax = positionmax + ds_parent(i)/2. 1385 1858 ELSE IF (type_update(i) == Agrif_Update_Full_Weighting) THEN … … 2007 2480 ds_parent, ds_child ) 2008 2481 ! 2482 elseif ( type_update == Agrif_Update_Max ) then 2483 ! 2484 call Agrif_basicupdate_max1d( & 2485 parent_tab, child_tab, & 2486 np, nc, & 2487 s_parent, s_child, & 2488 ds_parent, ds_child ) 2009 2489 elseif ( type_update == Agrif_Update_Full_Weighting ) then 2010 2490 ! -
vendors/AGRIF/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modupdatebasic.F90
r5656 r13027 220 220 end subroutine Agrif_basicupdate_average1d 221 221 !=================================================================================================== 222 223 !=================================================================================================== 224 ! subroutine Agrif_basicupdate_max1d 225 ! 226 !> Carries out an update by taking the maximum on a parent grid (vector x)from its child grid (vector y). 227 !--------------------------------------------------------------------------------------------------- 228 subroutine Agrif_basicupdate_max1d ( x, y, np, nc, s_parent, s_child, ds_parent, ds_child ) 229 !--------------------------------------------------------------------------------------------------- 230 REAL, DIMENSION(np), intent(out) :: x 231 REAL, DIMENSION(nc), intent(in) :: y 232 INTEGER, intent(in) :: np,nc 233 REAL, intent(in) :: s_parent, s_child 234 REAL, intent(in) :: ds_parent, ds_child 235 ! 236 INTEGER :: i, ii, locind_child_left, coeffraf 237 REAL :: xpos, invcoeffraf 238 INTEGER :: nbnonnuls 239 INTEGER :: diffmod 240 ! 241 coeffraf = nint(ds_parent/ds_child) 242 invcoeffraf = 1./coeffraf 243 ! 244 if (coeffraf == 1) then 245 locind_child_left = 1 + nint((s_parent - s_child)/ds_child) 246 x(1:np) = y(locind_child_left:locind_child_left+np-1) 247 return 248 endif 249 ! 250 xpos = s_parent 251 x = -HUGE(1.0) 252 ! 253 diffmod = 0 254 ! 255 IF ( mod(coeffraf,2) == 0 ) diffmod = 1 256 ! 257 locind_child_left = 1 + agrif_int((xpos - s_child)/ds_child) 258 ! 259 IF (Agrif_UseSpecialValueInUpdate) THEN 260 do i = 1,np 261 nbnonnuls = 0 262 !CDIR NOVECTOR 263 do ii = -coeffraf/2+locind_child_left+diffmod, & 264 coeffraf/2+locind_child_left 265 IF (y(ii) /= Agrif_SpecialValueFineGrid) THEN 266 x(i) = max(x(i),y(ii)) 267 ENDIF 268 enddo 269 locind_child_left = locind_child_left + coeffraf 270 enddo 271 ELSE 272 ! 273 !CDIR ALTCODE 274 do i = 1,np 275 !CDIR NOVECTOR 276 do ii = -coeffraf/2+locind_child_left+diffmod, & 277 coeffraf/2+locind_child_left 278 x(i) = max(x(i),y(ii)) 279 enddo 280 locind_child_left = locind_child_left + coeffraf 281 enddo 282 ENDIF 283 !--------------------------------------------------------------------------------------------------- 284 end subroutine Agrif_basicupdate_max1d 285 !=================================================================================================== 286 222 287 ! 223 288 !=================================================================================================== -
vendors/AGRIF/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modutil.F90
r12420 r13027 108 108 !--------------------------------------------------------------------------------------------------- 109 109 end subroutine Agrif_Step_Child 110 !=================================================================================================== 111 ! 112 !=================================================================================================== 113 ! subroutine Agrif_Step_Childs 114 ! 115 !> Apply 'procname' to each child grids of the current grid 116 !--------------------------------------------------------------------------------------------------- 117 ! ************************************************************************** 118 !!! Subroutine Agrif_Step_Childs 119 ! ************************************************************************** 120 ! 121 Subroutine Agrif_Step_Childs(procname) 122 ! 123 procedure(step_proc) :: procname !< subroutine to call on each grid 124 ! Pointer argument 125 Type(Agrif_Grid),pointer :: g ! Pointer on the current grid 126 ! 127 128 ! 129 ! Local pointer 130 Type(Agrif_pgrid),pointer :: parcours ! Pointer for the recursive 131 ! procedure 132 ! 133 g => Agrif_Curgrid 134 135 parcours => g % child_list % first 136 ! 137 ! Recursive procedure for the time integration of the grid hierarchy 138 Do while (associated(parcours)) 139 ! 140 ! Instanciation of the variables of the current grid 141 Call Agrif_Instance(parcours % gr) 142 143 ! One step on the current grid 144 145 Call procname () 146 parcours => parcours % next 147 enddo 148 149 If (associated(g % child_list % first)) Call Agrif_Instance (g) 150 Return 151 End Subroutine Agrif_Step_Childs 110 152 !=================================================================================================== 111 153 ! … … 538 580 !=================================================================================================== 539 581 ! 582 !=================================================================================================== 583 ! 540 584 ! 541 585 !=================================================================================================== … … 587 631 #ifdef AGRIF_MPI 588 632 else 589 #endif590 633 ! Continue only if the grid has defined sequences of child integrations. 591 634 if ( .not. associated(save_grid % child_seq) ) return … … 610 653 ! 611 654 enddo 612 #ifdef AGRIF_MPI613 655 endif 614 656 #endif … … 700 742 subroutine Agrif_Init_Grids ( procname1, procname2 ) 701 743 !--------------------------------------------------------------------------------------------------- 702 procedure(typ def_proc), optional :: procname1 !< (Default: Agrif_probdim_modtype_def)744 procedure(typedef_proc), optional :: procname1 !< (Default: Agrif_probdim_modtype_def) 703 745 procedure(alloc_proc), optional :: procname2 !< (Default: Agrif_Allocationcalls) 704 746 ! … … 717 759 nunit = Agrif_Get_Unit() 718 760 open(nunit, file='AGRIF_FixedGrids.in', form='formatted', status="old", ERR=98) 719 if (Agrif_Probdim == 3) then 720 read(nunit,*) is_coarse, rhox, rhoy, rhoz, rhot 721 elseif (Agrif_Probdim == 2) then 722 read(nunit,*) is_coarse, rhox, rhoy, rhot 723 elseif (Agrif_Probdim == 2) then 724 read(nunit,*) is_coarse, rhox, rhot 725 endif 761 read(nunit,*) is_coarse 726 762 if (is_coarse == -1) then 727 763 agrif_coarse = .TRUE. 764 rewind(nunit) 728 765 if (Agrif_Probdim == 3) then 766 read(nunit,*) is_coarse, rhox, rhoy, rhoz, rhot 729 767 coarse_spaceref(1:3)=(/rhox,rhoy,rhoz/) 730 768 elseif (Agrif_Probdim == 2) then 769 read(nunit,*) is_coarse, rhox, rhoy, rhot 731 770 coarse_spaceref(1:2)=(/rhox,rhoy/) 732 elseif (Agrif_Probdim == 2) then 771 elseif (Agrif_Probdim == 1) then 772 read(nunit,*) is_coarse, rhox, rhot 733 773 coarse_spaceref(1:1)=(/rhox/) 734 774 endif -
vendors/AGRIF/dev_r12970_AGRIF_CMEMS/AGRIF_FILES/modvariables.F90
r5656 r13027 99 99 Agrif_Curgrid % Nbvariables = Agrif_Curgrid % Nbvariables + 1 100 100 101 varid = -Agrif_Curgrid % Nbvariables101 varid = Agrif_Curgrid % Nbvariables 102 102 103 103 var % parent_var => Agrif_Search_Variable(Agrif_Curgrid % parent, Agrif_Curgrid % nbvariables) -
vendors/AGRIF/dev_r12970_AGRIF_CMEMS/LEX/Makefile.lex
r9140 r13027 1 1 LEX = flex -i 2 YACC = bison -t -v -g 2 YACC = /usr/bin/bison -t -v -g --graph 3 #YACC = byacc -t -v 3 4 4 5 all: main.c fortran.c 5 6 6 7 main.c : convert.tab.c convert.yy.c 7 cat convert.tab.c convert.yy.c > ../LIB/main.c8 cat convert.tab.c convert.yy.c > main.c 8 9 $(RM) convert.tab.c convert.yy.c 9 10 10 11 fortran.c : fortran.tab.c fortran.yy.c 11 cat fortran.tab.c fortran.yy.c > ../LIB/fortran.c12 cat fortran.tab.c fortran.yy.c > fortran.c 12 13 $(RM) fortran.tab.c fortran.yy.c 13 14 … … 29 30 30 31 clean-all: clean 31 $(RM) ../LIB/main.c ../LIB/fortran.c32 $(RM) main.c fortran.c -
vendors/AGRIF/dev_r12970_AGRIF_CMEMS/LEX/convert.y
r9140 r13027 130 130 int infreegiven ; 131 131 int infixedgiven ; 132 int lengthmainfile;133 132 134 133 char filetoparse[LONG_FNAME]; … … 160 159 tmpuselocallist = (listusemodule *) NULL; 161 160 List_ContainsSubroutine = (listnom *) NULL; 161 List_Do_labels = (listname *) NULL; 162 162 oldfortran_out = (FILE *) NULL; 163 163 164 if (argc < 2) print_usage(); 165 164 if ( argc < 2 ) 165 print_usage(); 166 166 167 strcpy(config_file, argv[1]); 167 168 strcpy(work_dir, "."); … … 257 258 strcpy(filetoparse, argv[i+1]); 258 259 i++; 259 lengthmainfile = strlen(filetoparse); 260 if (!strcasecmp(&filetoparse[lengthmainfile-4], ".f90")) 261 { 262 infixed = 0; 263 infree = 1; 264 } 265 else 266 { 267 infixed = 1; 268 infree = 0; 269 } 260 infree = (strstr(filetoparse, ".f90") != NULL) || (strstr(filetoparse, ".F90") != NULL); 261 infixed = ! infree; 270 262 } 271 263 else if (!strcasecmp(argv[i], "-free")) … … 400 392 /* Build new subroutines */ 401 393 firstpass = 0; 394 /* 395 printf("**********************************\n"); 396 printf("SECOND PASSES \n"); 397 printf("**********************************\n"); 398 */ 402 399 process_fortran(filetoparse); 403 400 -
vendors/AGRIF/dev_r12970_AGRIF_CMEMS/LEX/fortran.lex
r9140 r13027 39 39 %s character 40 40 %x donottreat 41 %x donottreat_interface 42 %x includestate 41 43 %s fortran77style 42 44 %s fortran90style … … 47 49 extern FILE * yyin; 48 50 #define MAX_INCLUDE_DEPTH 30 51 #define YY_BUF_SIZE 64000 49 52 YY_BUFFER_STATE include_stack[MAX_INCLUDE_DEPTH]; 50 int line_num_input = 1;53 int line_num_input = 0; 51 54 int newlinef90 = 0; 52 char tmpc; 53 #define PRINT_LINE_NUM() // { fprintf(stderr,"== Parsing l.%4d...\n", line_num_input); } 54 #define INCREMENT_LINE_NUM() { line_num_input++; PRINT_LINE_NUM(); } 55 56 /******************************************************************************/ 57 /**************PETITS PB NON PREVUS *******************************************/ 58 /******************************************************************************/ 59 /* NEXTLINF77 un ligne fortran 77 peut commencer par - &a=b or on */ 60 /* a prevu seulement & a=b avec l'espace entre le symbole */ 61 /* de la 7eme et le debut de la ligne de commande */ 62 /* le ! est aussi interdit comme symbole de la 7 eme colonne */ 63 /* Normalement NEXTLINEF77 \n+[ ]{5}[^ ] */ 64 /******************************************************************************/ 65 #define YY_USER_ACTION if (firstpass == 0) ECHO; 55 int tmpc; 56 57 int lastwasendofstmt = 1; 58 59 extern char linebuf1[1024]; 60 extern char linebuf2[1024]; 61 62 int count_newlines(const char* str_in) 63 { 64 int k, i = 0; 65 for( k=0 ; k<strlen(str_in) ; k++) 66 if (str_in[k] == '\n') i++; 67 return i; 68 } 69 70 #define PRINT_LINE_NUM() // { fprintf(stderr,"== Parsing l.%4d...\n", line_num_input); } 71 #define INCREMENT_LINE_NUM() { line_num_input+=count_newlines(fortran_text) ; PRINT_LINE_NUM(); } 72 #define YY_USER_ACTION { if (increment_nbtokens !=0) token_since_endofstmt++; increment_nbtokens = 1; if (token_since_endofstmt>=1) lastwasendofstmt=0; /*printf("VALLIJSDFLSD = %d %d %s \n",lastwasendofstmt,token_since_endofstmt,fortran_text); */ if (firstpass) { strcpy(linebuf1, linebuf2); strncpy(linebuf2, fortran_text,80);} \ 73 else {my_position_before=setposcur();/*printf("muposition = %d\n",my_position_before);*/ECHO;} } 74 #define YY_BREAK {/*printf("VALL = %d %d\n",lastwasendofstmt,token_since_endofstmt);*/if (token_since_endofstmt>=1) lastwasendofstmt=0; break;} 66 75 67 76 void out_of_donottreat(void); … … 69 78 %} 70 79 71 REAL8 "real*8"[ \t]*"(a-h,o-z)"72 73 80 SLASH "/" 74 DSLASH "/"[ \t]*"/"75 81 HEXA Z\'[0-9a-fA-F]+\' 76 NAME [a-zA-Z\_][a-zA-Z0-9\_]*77 82 INTEGER [0-9]+ 78 83 NAME [a-zA-Z][a-zA-Z0-9\_]* 79 84 EXPONENT [edq][-+]?{INTEGER} 80 85 81 BEG_DNT ^[C!]"$AGRIF_DO_NOT_TREAT"[ \t]* \n82 END_DNT ^[C!]"$AGRIF_END_DO_NOT_TREAT"[ \t]* \n86 BEG_DNT ^[C!]"$AGRIF_DO_NOT_TREAT"[ \t]*([ \t\n]*(!.*\n)*)+\n 87 END_DNT ^[C!]"$AGRIF_END_DO_NOT_TREAT"[ \t]*([ \t\n]*(!.*\n)*)+\n 83 88 84 89 BEG_INTERFACE ^[ \t]*interface … … 87 92 ASSIGNTYPE "assignment"[ \t]*"("[ \t]*[-+=]+[ \t]*")" 88 93 89 COMM_F77 ^ ([Cc*](([ \t]*\n)|([^AaHhOo\n].*\n)))90 COMM_F90 ^[ \t]*!.*\n94 COMM_F77 ^[c*].*\n 95 COMM_F90_1 ^([ \t\n]*(!.*\n)*)+\n 91 96 COMM_F90_2 !.* 92 NEXTLINEF90 "&".*\n+ 93 NEXTLINEF77 [\n \t]*\n[ \t]{5}("&"|"+"|"$"|"*"|"1"|"2"|"3"|"4"|"5"|"6"|"7"|"8"|"9"|"."|"#") 94 95 LABEL ^(((" "|[0-9]){1,5})|([ \t]{1,5}))[ &]+ 97 NEXTLINEF90 &([ \t\n]|(!.*\n))* 98 NEXTLINEF77 \n(([c*].*\n)|(([ \t]{0,4}|[ \t]{6,})!.*\n)|[\n])*[ ]{5}([a-z0-9&+$*.#/!;]) 99 LABEL ^[ 0-9]{1,5}[ \t]+ 96 100 97 101 %% … … 99 103 if (infree) BEGIN(fortran90style) ; 100 104 101 {REAL8} { return TOK_REAL8; }102 105 subroutine { return TOK_SUBROUTINE; } 103 106 program { return TOK_PROGRAM; } 104 107 allocate { inallocate = 1; return TOK_ALLOCATE; } 108 continue { return TOK_CONTINUE; } 105 109 nullify { return TOK_NULLIFY; } 106 null[ ]*\([ ]*\) { return TOK_NULL_PTR; }107 110 deallocate { inallocate = 1; return TOK_DEALLOCATE; } 108 111 result { return TOK_RESULT; } 109 112 function { return TOK_FUNCTION; } 110 end[ \t]*program { strcpy(yylval.na,fortran_text); return TOK_ENDPROGRAM;}111 end[ \t]*module { strcpy(yylval.na,fortran_text); return TOK_ENDMODULE; }112 end[ \t]*subroutine { strcpy(yylval.na,fortran_text); return TOK_ENDSUBROUTINE;}113 end[ \t]*function { strcpy(yylval.na,fortran_text); return TOK_ENDFUNCTION;}114 113 end { strcpy(yylval.na,fortran_text); return TOK_ENDUNIT;} 115 include { pos_curinclude = setposcur()-9; return TOK_INCLUDE;} 116 ^[ \t]*use[ ]+ { strcpy(yylval.na,fortran_text); 117 tmpc = (char) input(); unput(tmpc); 118 if ( ( tmpc >= 'a' && tmpc <= 'z' ) || 119 ( tmpc >= 'A' && tmpc <= 'Z' ) ) return TOK_USE; 120 else return TOK_NAME; 121 } 114 include { pos_curinclude = setposcur()-9; BEGIN(includestate); } 115 use { return TOK_USE;} 122 116 rewind { return TOK_REWIND; } 123 117 implicit { return TOK_IMPLICIT; } 124 118 none { return TOK_NONE; } 125 119 call { return TOK_CALL; } 126 .true. { return TOK_TRUE; }127 .false. { return TOK_FALSE; }120 .true. { strcpy(yylval.na,fortran_text); return TOK_TRUE; } 121 .false. { strcpy(yylval.na,fortran_text); return TOK_FALSE; } 128 122 \=\> { return TOK_POINT_TO; } 129 123 {ASSIGNTYPE} { strcpy(yylval.na,fortran_text); return TOK_ASSIGNTYPE;} 130 124 \*\* { strcpy(yylval.na,fortran_text); return TOK_DASTER; } 131 \. [ \t]*eqv\. { strcpy(yylval.na,fortran_text); return TOK_EQV; }132 \.[ \t]*eq \. { strcpy(yylval.na,fortran_text); return TOK_EQ; }133 \. [ \t]*gt\. { strcpy(yylval.na,fortran_text); return TOK_GT; }134 \. [ \t]*ge\. { strcpy(yylval.na,fortran_text); return TOK_GE; }135 \. [ \t]*lt\. { strcpy(yylval.na,fortran_text); return TOK_LT; }136 \. [ \t]*le\. { strcpy(yylval.na,fortran_text); return TOK_LE; }137 \. [ \t]*neqv\. { strcpy(yylval.na,fortran_text); return TOK_NEQV;}138 \.[ \t]*ne \. { strcpy(yylval.na,fortran_text); return TOK_NE; }139 \. [ \t]*not\. { strcpy(yylval.na,fortran_text); return TOK_NOT; }140 \. [ \t]*or\. { strcpy(yylval.na,fortran_text); return TOK_OR; }125 \.eqv\. { strcpy(yylval.na,fortran_text); return TOK_EQV; } 126 \.[ \t]*eq[ \t]*\. { strcpy(yylval.na,fortran_text); return TOK_EQ; } 127 \.gt\. { strcpy(yylval.na,fortran_text); return TOK_GT; } 128 \.ge\. { strcpy(yylval.na,fortran_text); return TOK_GE; } 129 \.lt\. { strcpy(yylval.na,fortran_text); return TOK_LT; } 130 \.le\. { strcpy(yylval.na,fortran_text); return TOK_LE; } 131 \.neqv\. { strcpy(yylval.na,fortran_text); return TOK_NEQV;} 132 \.[ \t]*ne[ \t]*\. { strcpy(yylval.na,fortran_text); return TOK_NE; } 133 \.not\. { strcpy(yylval.na,fortran_text); return TOK_NOT; } 134 \.or\. { strcpy(yylval.na,fortran_text); return TOK_OR; } 141 135 \.[ \t]*xor\. { strcpy(yylval.na,fortran_text); return TOK_XOR; } 142 \.[ \t]*and\. { strcpy(yylval.na,fortran_text); return TOK_AND; } 136 \.and\. { strcpy(yylval.na,fortran_text); return TOK_AND; } 137 \=\= { strcpy(yylval.na,fortran_text); return TOK_EQUALEQUAL; } 138 \/\= { strcpy(yylval.na,fortran_text); return TOK_SLASHEQUAL; } 139 \<\= { strcpy(yylval.na,fortran_text); return TOK_INFEQUAL; } 140 \>\= { strcpy(yylval.na,fortran_text); return TOK_SUPEQUAL; } 143 141 module { return TOK_MODULE; } 144 142 while { return TOK_WHILE; } 145 143 concurrent { return TOK_CONCURRENT; } 146 144 end[ \t]*do { return TOK_ENDDO; } 147 do { return TOK_PLAINDO;} 145 do[\ t]+{INTEGER} { strcpy(yylval.na,&fortran_text[2]); 146 if (testandextractfromlist(&List_Do_labels,&fortran_text[2]) == 1) 147 { 148 return TOK_PLAINDO_LABEL_DJVIEW; 149 } 150 else 151 { 152 List_Do_labels=Insertname(List_Do_labels,yylval.na,1); 153 return TOK_PLAINDO_LABEL; 154 } 155 } 156 do { increment_nbtokens = 0; return TOK_PLAINDO;} 148 157 real { strcpy(yylval.na,fortran_text); return TOK_REAL; } 149 158 integer { strcpy(yylval.na,fortran_text); return TOK_INTEGER; } … … 153 162 double[ \t]*precision { strcpy(yylval.na,fortran_text); return TOK_DOUBLEPRECISION; } 154 163 double[ \t]*complex { strcpy(yylval.na,fortran_text); return TOK_DOUBLECOMPLEX; } 155 complex { return TOK_COMPLEX; }164 complex { strcpy(yylval.na,fortran_text); return TOK_COMPLEX; } 156 165 allocatable { return TOK_ALLOCATABLE; } 157 166 close { return TOK_CLOSE; } … … 172 181 ^[ \t]*global[ \t]+ { return TOK_GLOBAL; } 173 182 external { return TOK_EXTERNAL; } 174 intent { return TOK_INTENT; }183 intent { intent_spec = 1; return TOK_INTENT; } 175 184 pointer { return TOK_POINTER; } 176 185 optional { return TOK_OPTIONAL; } 177 186 save { return TOK_SAVE; } 178 ^[ \t]*type[ \t]*\( { pos_cur_decl = setposcur()- 5; return TOK_TYPEPAR; }179 ^[ \t]*type [ \t\,]+{ return TOK_TYPE; }187 ^[ \t]*type[ \t]*\( { pos_cur_decl = setposcur()-strlen(fortran_text); return TOK_TYPEPAR; } 188 ^[ \t]*type/[ \t\,:]+ { return TOK_TYPE; } 180 189 end[ \t]*type { return TOK_ENDTYPE; } 181 190 stat { if (inallocate == 1) return TOK_STAT; else { strcpy(yylval.na,fortran_text); return TOK_NAME; } } 182 191 open { return TOK_OPEN; } 183 192 return { return TOK_RETURN; } 184 exit [^(]{ return TOK_EXIT; }193 exit { return TOK_EXIT; } 185 194 print { return TOK_PRINT; } 186 195 module[ \t]*procedure { return TOK_PROCEDURE; } 196 read[ \t]*\( { in_io_control_spec = 1; return TOK_READ_PAR; } 187 197 read { return TOK_READ; } 188 198 namelist { return TOK_NAMELIST; } 199 write[ \t]*\( { in_io_control_spec = 1; return TOK_WRITE_PAR; } 189 200 write { return TOK_WRITE; } 190 flush { return TOK_FLUSH; }201 flush { strcpy(yylval.na,fortran_text); return TOK_FLUSH; } 191 202 target { return TOK_TARGET; } 192 203 public { return TOK_PUBLIC; } 193 204 private { return TOK_PRIVATE; } 194 in { strcpy(yylval.na,fortran_text); return TOK_IN; } 195 ^[ \t]*data[ \t]+ { pos_curdata = setposcur()-strlen(fortran_text); Init_List_Data_Var(); return TOK_DATA; } 196 continue { return TOK_CONTINUE; } 205 in { strcpy(yylval.na,fortran_text); 206 if (intent_spec==1) 207 {return TOK_IN; } 208 else 209 { 210 return TOK_NAME; 211 } 212 } 213 ^[ \t]*data[ \t]+ { pos_curdata = setposcur()-strlen(fortran_text); /*Init_List_Data_Var();*/ return TOK_DATA; } 197 214 go[ \t]*to { return TOK_PLAINGOTO; } 198 out { strcpy(yylval.na,fortran_text); return TOK_OUT; } 199 inout { strcpy(yylval.na,fortran_text); return TOK_INOUT; } 215 out { strcpy(yylval.na,fortran_text); 216 if (intent_spec==1) 217 {return TOK_OUT; } 218 else 219 { 220 return TOK_NAME; 221 } 222 } 223 inout { strcpy(yylval.na,fortran_text); 224 if (intent_spec==1) 225 {return TOK_IN; } 226 else 227 { 228 return TOK_INOUT; 229 } 230 } 200 231 intrinsic { return TOK_INTRINSIC; } 201 232 then { return TOK_THEN; } … … 203 234 else { return TOK_ELSE; } 204 235 end[ \t]*if { return TOK_ENDIF; } 205 if { return TOK_LOGICALIF; } 206 sum[ \t]*\( { return TOK_SUM; } 207 max[ \t]*\( { return TOK_MAX; } 208 tanh { return TOK_TANH; } 209 maxval { return TOK_MAXVAL; } 210 trim { return TOK_TRIM; } 211 sqrt\( { return TOK_SQRT; } 236 if[ \t]*\(/(.*\)[ \t]*[\=|\+|\-]+.*\)) {strcpy(yylval.na,fortran_text); 237 return TOK_LOGICALIF_PAR; 238 } 239 if/([ \t]*\([^(]*\)[ \t]*[\=|\+|\-]+) {strcpy(yylval.na,fortran_text); 240 return TOK_NAME; 241 } 242 if[ \t]*\( {strcpy(yylval.na,fortran_text); 243 return TOK_LOGICALIF_PAR; 244 } 212 245 select[ \t]*case { return TOK_SELECTCASE; } 213 ^[ \t]*case[ \t]* { return TOK_CASE;}246 ^[ \t]*case[ \t]* { if (in_select_case_stmt > 0) return TOK_CASE ; else return TOK_NAME;} 214 247 default { return TOK_DEFAULT; } 215 248 end[ \t]*select { return TOK_ENDSELECT; } 216 249 file[ \t]*\= { return TOK_FILE; } 250 access[ \t]*\= { return TOK_ACCESS; } 251 action[ \t]*\= { return TOK_ACTION; } 252 iolength[ \t]*\= { return TOK_IOLENGTH; } 217 253 unit[ \t]*\= { return TOK_UNIT; } 254 opened[ \t]*\= { return TOK_OPENED; } 218 255 fmt[ \t]*\= { return TOK_FMT; } 219 256 nml[ \t]*\= { return TOK_NML; } 220 257 end[ \t]*\= { return TOK_END; } 221 258 eor[ \t]*\= { return TOK_EOR; } 259 len/([ \t]*\=) { 260 if (in_char_selector ==1) 261 return TOK_LEN; 262 else 263 { 264 strcpy(yylval.na,fortran_text); return TOK_NAME; 265 } 266 } 267 kind/([ \t]*\=) { 268 if ((in_char_selector==1) || (in_kind_selector == 1)) 269 return TOK_KIND; 270 else 271 { 272 strcpy(yylval.na,fortran_text); return TOK_NAME; 273 } 274 } 275 errmsg[ \t]*\= { return TOK_ERRMSG; } 276 mold[ \t]*\= { return TOK_MOLD; } 277 source[ \t]*\= { return TOK_SOURCE; } 278 position[ \t]*\= { return TOK_POSITION; } 279 iomsg[ \t]*\= { return TOK_IOMSG; } 280 iostat[ \t]*\= { return TOK_IOSTAT; } 222 281 err[ \t]*\= { return TOK_ERR; } 282 form[ \t]*\= { return TOK_FORM; } 283 name/([ \t]*\=) { 284 if (in_inquire==1) 285 return TOK_NAME_EQ; 286 else 287 { 288 strcpy(yylval.na,fortran_text); return TOK_NAME; 289 } 290 } 291 recl[ \t]*\= { return TOK_RECL; } 292 rec/([ \t]*\=) { if (in_io_control_spec == 1) 293 return TOK_REC; 294 else 295 { 296 strcpy(yylval.na,fortran_text); return TOK_NAME; 297 } 298 } 299 status/([ \t]*\=) { if (close_or_connect == 1) 300 return TOK_STATUS; 301 else 302 { 303 strcpy(yylval.na,fortran_text); return TOK_NAME; 304 } 305 } 306 status { strcpy(yylval.na,fortran_text); return TOK_NAME;} 223 307 exist[ \t]*\= { return TOK_EXIST; } 224 min[ \t]*\( { return TOK_MIN; }225 nint { return TOK_NINT; }226 float { return TOK_FLOAT; }227 exp { return TOK_EXP; }228 cos { return TOK_COS; }229 cosh { return TOK_COSH; }230 acos { return TOK_ACOS; }231 sin { return TOK_SIN; }232 sinh { return TOK_SINH; }233 asin { return TOK_ASIN; }234 log { return TOK_LOG; }235 tan { return TOK_TAN; }236 atan { return TOK_ATAN; }237 308 cycle { return TOK_CYCLE; } 238 abs[ \t]*\( { return TOK_ABS; }239 mod { return TOK_MOD; }240 sign[ \t]*\( { return TOK_SIGN; }241 minloc { return TOK_MINLOC; }242 maxloc { return TOK_MAXLOC; }243 minval { return TOK_MINVAL; }244 309 backspace { return TOK_BACKSPACE; } 245 310 :: { return TOK_FOURDOTS; } 311 \/[ \t]*({NEXTLINEF90}|{NEXTLINEF77})*[ \t]*\/ { strcpy(yylval.na,fortran_text); return TOK_DSLASH; } 246 312 \({SLASH} { return TOK_LEFTAB; } 247 313 {SLASH}\) { return TOK_RIGHTAB; } 248 format[ \t]*\((.|{NEXTLINEF90}|{NEXTLINEF77})*\) {249 return TOK_FORMAT; }250 314 {SLASH} { strcpy(yylval.na,fortran_text); return TOK_SLASH; } 251 DSLASH { strcpy(yylval.na,fortran_text); return TOK_DSLASH; } 252 (\')[^']*&{0,1}\n[ \t]*&{0,1}[^']*(\') { 253 strcpy(yylval.na,fortran_text); return TOK_CHAR_CUT; } 254 (\')[^']*(\') { strcpy(yylval.na,fortran_text);return TOK_CHAR_CONSTANT; } 255 (\")[^"]*(\") { strcpy(yylval.na,fortran_text);return TOK_CHAR_MESSAGE; } 256 {BEG_INTERFACE} { BEGIN(donottreat); } 257 <donottreat>{END_INTERFACE} { out_of_donottreat(); return '\n'; } 315 ((\')[^']*&{0,1}\n[ \t]*&{0,1}[^']*(\'))+ { 316 INCREMENT_LINE_NUM() ; strcpy(yylval.na,fortran_text); return TOK_CHAR_CUT; } 317 <includestate>((\')[^']*(\'))+ {Add_Include_1(fortran_text);} 318 <includestate>[ \t]* {} 319 <includestate>\n { 320 if (inmoduledeclare == 0 ) 321 { 322 pos_end=setposcur(); 323 RemoveWordSET_0(fortran_out,pos_curinclude,pos_end-pos_curinclude); 324 } 325 out_of_donottreat(); 326 } 327 ((\')[^']*(\'))+ { strcpy(yylval.na,fortran_text);return TOK_CHAR_CONSTANT; } 328 ((\")[^"]*(\"))+ { strcpy(yylval.na,fortran_text);return TOK_CHAR_MESSAGE; } 329 {BEG_INTERFACE} { BEGIN(donottreat_interface); } 330 <donottreat_interface>{END_INTERFACE} { out_of_donottreat(); return '\n'; } 331 <donottreat_interface>.*\n {INCREMENT_LINE_NUM() ; } 332 <fortran77style>{NAME}{NEXTLINEF77}[a-zA-Z0-9\_]+ {strcpy(yylval.na,fortran_text); removenewline(yylval.na); 333 return TOK_NAME; } 258 334 {NAME} { strcpy(yylval.na,fortran_text); return TOK_NAME; } 335 {INTEGER}\.[0-9]+ {strcpy(yylval.na,fortran_text); return TOK_CSTREAL; } 259 336 ({INTEGER}\.[0-9]*)/[^"and."|"false."|"true."|"eq."|"or."|"gt."|"ge."|"lt."|"le."|"not."|"ne."] { // REAL1 260 337 strcpy(yylval.na,fortran_text); return TOK_CSTREAL; } 261 338 (({INTEGER}\.[0-9]+|[0-9]*\.{INTEGER}){EXPONENT}?)|{INTEGER}(\.)?{EXPONENT} { // REAL2 262 339 strcpy(yylval.na,fortran_text); return TOK_CSTREAL; } 263 {INTEGER} { strcpy(yylval.na,fortran_text); return TOK_CSTINT; } 340 {INTEGER} { strcpy(yylval.na,fortran_text); 341 if (lastwasendofstmt == 0) 342 return TOK_CSTINT; 343 else 344 if (testandextractfromlist(&List_Do_labels,fortran_text) == 1) 345 { 346 removefromlist(&List_Do_labels,yylval.na); 347 return TOK_LABEL_DJVIEW; 348 } 349 else 350 { 351 return TOK_LABEL; 352 } 353 } 264 354 \$ {} 265 355 \. {} 266 \(|\)|:|\[|\]|\+|\-|\* { strcpy(yylval.na,fortran_text); return (int) *fortran_text; } 356 \(/([ \t]*[\+\-]?[a-zA-Z0-9]+[\.]*[0-9]*(\_({INTEGER}|{NAME}))?[ \t]*\,[ \t]*[\+\-]?[a-zA-Z0-9]+[\.]*[0-9]*(\_({INTEGER}|{NAME}))?[ \t]*\)) { 357 in_complex_literal = -1; 358 return (int) *fortran_text; 359 } 360 \(|\)|:|\[|\]|\+|\-|\*|\_ { strcpy(yylval.na,fortran_text); return (int) *fortran_text; } 267 361 \% { strcpy(yylval.na,fortran_text); return (int) *fortran_text; } 268 \; { return TOK_SEMICOLON; }269 \, { return (int) *fortran_text; }362 \; { lastwasendofstmt=1; token_since_endofstmt = 0; return TOK_SEMICOLON; } 363 \, { if (in_complex_literal==-1) {return TOK_COMMACOMPLEX; in_complex_literal=0;} else; return (int) *fortran_text; } 270 364 \= { return (int) *fortran_text; } 271 365 \< { return (int) *fortran_text; } 272 366 \> { return (int) *fortran_text; } 273 \n { INCREMENT_LINE_NUM() ; return '\n'; } 274 ^[ ]*$ {} 275 [ \t]+ {} 276 {LABEL} { if (newlinef90 == 0) return TOK_LABEL; else newlinef90 = 0; } 367 \n { INCREMENT_LINE_NUM() ; lastwasendofstmt=1; token_since_endofstmt = 0; increment_nbtokens = 0; return '\n'; } 368 [ \t]+ {increment_nbtokens = 0;} 369 <fortran77style>{LABEL}[ \t]*format[ \t]*\((.|{NEXTLINEF90}|{NEXTLINEF77})*\) { 370 return TOK_LABEL_FORMAT; } 371 <fortran90style>^[ \t]*{INTEGER}[ \t]*format[ \t]*\((.|{NEXTLINEF90})*\) {return TOK_LABEL_FORMAT; } 277 372 {NEXTLINEF90} { INCREMENT_LINE_NUM() ; newlinef90=1; } 278 {NEXTLINEF77} { INCREMENT_LINE_NUM() ; } 279 280 {BEG_DNT} { INCREMENT_LINE_NUM() ; BEGIN(donottreat); } 281 <donottreat>{END_DNT} { out_of_donottreat(); return '\n'; } 282 <donottreat>.*\n { INCREMENT_LINE_NUM() ; } 283 <fortran77style>{COMM_F77} { INCREMENT_LINE_NUM() ; } 284 {COMM_F90} { INCREMENT_LINE_NUM() ; } 285 {COMM_F90_2} {} 373 <fortran77style>{NEXTLINEF77} { INCREMENT_LINE_NUM() ;} 374 375 {BEG_DNT} {INCREMENT_LINE_NUM() ; BEGIN(donottreat); } 376 <donottreat>{END_DNT} {out_of_donottreat(); return '\n'; } 377 <donottreat>.*\n {INCREMENT_LINE_NUM() ; } 378 <fortran77style>{COMM_F77} {INCREMENT_LINE_NUM() ; increment_nbtokens = 0;} 379 {COMM_F90_1} {INCREMENT_LINE_NUM() ; increment_nbtokens = 0;} 380 {COMM_F90_2} {increment_nbtokens = 0;} 381 <<EOF>> {endoffile = 1; yyterminate();} 286 382 %% 287 383 -
vendors/AGRIF/dev_r12970_AGRIF_CMEMS/LEX/fortran.y
r12420 r13027 42 42 43 43 extern int line_num_input; 44 extern char *fortran_text;45 44 46 45 char c_selectorname[LONG_M]; … … 50 49 int c_selectorgiven=0; 51 50 listvar *curlistvar; 51 int in_select_case_stmt=0; 52 52 typedim c_selectordim; 53 53 listcouple *coupletmp; 54 54 int removeline=0; 55 int token_since_endofstmt = 0; 56 int increment_nbtokens = 1; 57 int in_complex_literal = 0; 58 int close_or_connect = 0; 59 int in_io_control_spec = 0; 60 int intent_spec = 0; 61 long int my_position; 62 long int my_position_before; 63 int suborfun = 0; 64 int indeclaration = 0; 65 int endoffile = 0; 66 int in_inquire = 0; 67 int in_char_selector = 0; 68 int in_kind_selector =0; 69 int char_length_toreset = 0; 70 71 typedim my_dim; 72 55 73 listvar *test; 74 75 char linebuf1[1024]; 76 char linebuf2[1024]; 56 77 57 78 int fortran_error(const char *s) 58 79 { 59 printf("%s line %d, file %s motclef = |%s|\n", s, line_num_input, cur_filename, fortran_text); 80 if (endoffile == 1) 81 { 82 endoffile = 0; 83 return 0; 84 } 85 printf("%s line %d, file %s culprit = |%s|\n", s, line_num_input, cur_filename, strcat(linebuf1, linebuf2)); 60 86 exit(1); 61 87 } … … 94 120 %token TOK_PROGRAM 95 121 %token TOK_FUNCTION 96 %token TOK_FORMAT 122 %token TOK_LABEL_FORMAT 123 %token TOK_LABEL_CONTINUE 124 %token TOK_LABEL_END_DO 97 125 %token TOK_MAX 98 126 %token TOK_TANH 127 %token TOK_COMMENT 99 128 %token TOK_WHERE 100 129 %token TOK_ELSEWHEREPAR … … 109 138 %token TOK_SELECTCASE 110 139 %token TOK_FILE 140 %token TOK_REC 141 %token TOK_NAME_EQ 142 %token TOK_IOLENGTH 143 %token TOK_ACCESS 144 %token TOK_ACTION 145 %token TOK_FORM 146 %token TOK_RECL 147 %token TOK_STATUS 111 148 %token TOK_UNIT 149 %token TOK_OPENED 112 150 %token TOK_FMT 113 151 %token TOK_NML 114 152 %token TOK_END 115 153 %token TOK_EOR 154 %token TOK_EOF 116 155 %token TOK_ERR 156 %token TOK_POSITION 157 %token TOK_IOSTAT 158 %token TOK_IOMSG 117 159 %token TOK_EXIST 118 160 %token TOK_MIN 119 161 %token TOK_FLOAT 120 162 %token TOK_EXP 163 %token TOK_LEN 121 164 %token TOK_COS 122 165 %token TOK_COSH … … 139 182 %token TOK_MAXLOC 140 183 %token TOK_EXIT 184 %token TOK_KIND 185 %token TOK_MOLD 186 %token TOK_SOURCE 187 %token TOK_ERRMSG 141 188 %token TOK_MINVAL 142 189 %token TOK_PUBLIC … … 150 197 %token TOK_PRINT 151 198 %token TOK_PLAINGOTO 152 %token TOK_LOGICALIF 199 %token <na> TOK_LOGICALIF 200 %token <na> TOK_LOGICALIF_PAR 153 201 %token TOK_PLAINDO 154 202 %token TOK_CONTAINS … … 162 210 %token TOK_CLOSE 163 211 %token TOK_INQUIRE 212 %token TOK_WRITE_PAR 164 213 %token TOK_WRITE 165 %token TOK_FLUSH 214 %token <na> TOK_FLUSH 215 %token TOK_READ_PAR 166 216 %token TOK_READ 167 217 %token TOK_REWIND … … 192 242 %token TOK_PROCEDURE 193 243 %token TOK_STOP 194 %token TOK_REAL8195 244 %token TOK_FOURDOTS 196 245 %token <na> TOK_HEXA … … 214 263 %token <na> TOK_NOT 215 264 %token <na> TOK_AND 265 %token <na> TOK_EQUALEQUAL 266 %token <na> TOK_SLASHEQUAL 267 %token <na> TOK_INFEQUAL 268 %token <na> TOK_SUPEQUAL 216 269 %token <na> TOK_TRUE 217 270 %token <na> TOK_FALSE 218 271 %token <na> TOK_LABEL 272 %token <na> TOK_LABEL_DJVIEW 273 %token <na> TOK_PLAINDO_LABEL_DJVIEW 274 %token <na> TOK_PLAINDO_LABEL 219 275 %token <na> TOK_TYPE 220 276 %token <na> TOK_TYPEPAR 221 277 %token <na> TOK_ENDTYPE 278 %token TOK_COMMACOMPLEX 222 279 %token <na> TOK_REAL 223 280 %token <na> TOK_INTEGER … … 246 303 %token '>' 247 304 %type <l> dcl 248 %type <l> after_type249 305 %type <l> dimension 306 %type <l> array-name-spec-list 250 307 %type <l> paramlist 251 308 %type <l> args 309 %type <na> declaration-type-spec 252 310 %type <l> arglist 253 311 %type <lc> only_list 312 %type <lc> only-list 313 %type <lc> opt-only-list 314 %type <lc> only 254 315 %type <lc> only_name 255 %type <lc> rename_list 256 %type <lc> rename_name 316 %type <lc> rename-list 317 %type <lc> opt-rename-list 318 %type <lc> rename 257 319 %type <d> dims 258 320 %type <d> dimlist … … 261 323 %type <na> comblock 262 324 %type <na> name_routine 325 %type <na> type-param-value 263 326 %type <na> opt_name 327 %type <na> constant-expr 328 %type <na> ac-implied-do 329 %type <na> subroutine-name 330 %type <l> opt-dummy-arg-list-par 331 %type <l> opt-dummy-arg-list 332 %type <l> dummy-arg-list 333 %type <l> named-constant-def-list 334 %type <v> named-constant-def 335 %type <na> ac-do-variable 336 %type <na> data-i-do-variable 337 %type <na> data-stmt-constant 338 %type <na> do-variable 339 %type <na> ac-implied-do-control 340 %type <na> label 341 %type <na> opt-label 342 %type <na> label-djview 343 %type <na> opt-label-djview 264 344 %type <na> type 265 %type <na> word_endsubroutine 266 %type <na> word_endfunction 267 %type <na> word_endprogram 268 %type <na> word_endunit 345 %type <na> real-literal-constant 346 %type <l> type-declaration-stmt 347 %type <d> array-spec 348 %type <d> assumed-shape-spec-list 349 %type <d> deferred-shape-spec-list 350 %type <d> assumed-size-spec 351 %type <d> implied-shape-spec-list 269 352 %type <na> typespec 353 %type <na> null-init 354 %type <na> initial-data-target 355 %type <na> intent-spec 270 356 %type <na> string_constant 357 %type <na> access-id 358 %type <na> dummy-arg-name 359 %type <na> common-block-name 360 %type <na> function-name 361 %type <na> dummy-arg 362 %type <na> lower-bound 363 %type <na> upper-bound 364 %type <na> scalar-constant-subobject 365 %type <na> opt-data-stmt-star 271 366 %type <na> simple_const 367 %type <na> opt-char-selector 368 %type <na> char-selector 272 369 %type <na> ident 273 370 %type <na> intent_spec 371 %type <na> kind-param 274 372 %type <na> signe 373 %type <na> scalar-int-constant-expr 275 374 %type <na> opt_signe 375 %type <dim1> explicit-shape-spec 376 %type <d> explicit-shape-spec-list 377 %type <dim1> assumed-shape-spec 378 %type <dim1> deferred-shape-spec 276 379 %type <na> filename 277 380 %type <na> attribute … … 279 382 %type <na> begin_array 280 383 %type <na> clause 384 %type <na> only-use-name 385 %type <na> generic-spec 281 386 %type <na> arg 387 %type <d> opt-array-spec-par 388 %type <d> opt-explicit-shape-spec-list-comma 389 %type <d> explicit-shape-spec-list-comma 282 390 %type <na> uexpr 391 %type <na> section_subscript_ambiguous 283 392 %type <na> minmaxlist 393 %type <na> subscript 394 %type <na> subscript-triplet 395 %type <na> vector-subscript 284 396 %type <na> lhs 285 %type <na> vec286 397 %type <na> outlist 287 398 %type <na> other 399 %type <na> int-constant-expr 288 400 %type <na> dospec 289 401 %type <na> expr_data … … 298 410 %type <na> opt_expr 299 411 %type <na> optexpr 412 %type <v> entity-decl 413 %type <l> entity-decl-list 300 414 %type <lnn> data_stmt_value_list 415 %type <lnn> data-stmt-value-list 416 %type <lnn> access-id-list 417 %type <lnn> opt-access-id-list 418 %type <na> data-stmt-value 419 %type <l> data-stmt-object-list 420 %type <l> data-i-do-object-list 421 %type <v> data-stmt-object 422 %type <v> data-i-do-object 301 423 %type <lnn> datanamelist 302 424 %type <na> after_slash 303 425 %type <na> after_equal 304 426 %type <na> predefinedfunction 427 %type <na> equiv-op 428 %type <na> or-op 429 %type <na> and-op 430 %type <na> not-op 431 %type <na> equiv-operand 432 %type <na> or-operand 433 %type <na> and-operand 434 %type <na> mult-operand 435 %type <na> rel-op 436 %type <na> concat-op 437 %type <na> add-operand 438 %type <na> add-op 439 %type <na> power-op 440 %type <na> section-subscript-list 441 %type <na> opt-lower-bound-2points 442 %type <na> mult-op 443 %type <na> array-constructor 305 444 %type <na> expr 445 %type <na> function-reference 446 %type <na> literal-constant 447 %type <na> named-constant 448 %type <na> ac-value-list 449 %type <na> ac-value 450 %type <na> intrinsic-type-spec 451 %type <na> opt-kind-selector 452 %type <na> char-literal-constant 453 %type <na> logical-literal-constant 454 %type <na> real-part 455 %type <na> imag-part 456 %type <na> sign 457 %type <na> signed-int-literal-constant 458 %type <na> int-literal-constant 459 %type <na> signed-real-literal-constant 460 %type <na> complex-literal-constant 461 %type <na> actual-arg-spec-list 462 %type <na> procedure-designator 463 %type <na> constant 464 %type <na> data-ref 465 %type <v> structure-component 466 %type <v> scalar-structure-component 467 %type <na> int-expr 468 %type <na> ac-spec 469 %type <na> type-spec 470 %type <na> derived-type-spec 471 %type <v> part-ref 472 %type <na> opt-part-ref 473 %type <na> actual-arg-spec 474 %type <na> kind-selector 475 %type <na> actual-arg 476 %type <na> section-subscript 477 %type <na> keyword 478 %type <na> primary 479 %type <na> specification-expr 480 %type <v> variable 481 %type <v> data-implied-do 482 %type <na> substring-range 483 %type <v> designator 484 %type <na> object-name 485 %type <na> object-name-noident 486 %type <na> array-element 487 %type <na> array-section 488 %type <na> scalar-variable-name 489 %type <na> scalar-constant 490 %type <na> variable-name 491 %type <na> opt-subscript 492 %type <na> stride 493 %type <na> opt-scalar-int-expr 494 %type <na> scalar-int-expr 495 %type <na> level-1-expr 496 %type <na> level-2-expr 497 %type <na> level-3-expr 498 %type <na> level-4-expr 499 %type <na> level-5-expr 306 500 %type <na> ubound 307 501 %type <na> operation … … 311 505 312 506 %% 313 input : 507 /* R201 : program */ 508 /*program: line-break 509 | program-unit 510 | program program-unit 511 ; 512 */ 513 514 input: 314 515 | input line 315 516 ; 316 line 517 line: line-break 317 518 | suite_line_list 318 | TOK_LABEL suite_line_list319 519 | error {yyerrok;yyclearin;} 320 520 ; 321 line-break: 322 '\n' fin_line521 line-break: '\n' fin_line 522 {token_since_endofstmt = 0; increment_nbtokens = 0;} 323 523 | TOK_SEMICOLON 524 | TOK_EOF 324 525 | line-break '\n' fin_line 325 526 | line-break TOK_SEMICOLON 326 | line-break TOK_LABEL327 527 ; 328 528 suite_line_list : … … 331 531 | suite_line_list TOK_SEMICOLON suite_line 332 532 ; 333 suite_line : 334 entry fin_line /* subroutine, function, module */ 335 | spec fin_line /* declaration */ 533 suite_line:program-unit 336 534 | TOK_INCLUDE filename fin_line 337 535 { … … 342 540 } 343 541 } 542 | TOK_COMMENT 543 ; 544 /* 545 suite_line: 546 entry fin_line subroutine, function, module 547 | spec fin_line declaration 548 | TOK_INCLUDE filename fin_line 549 { 550 if (inmoduledeclare == 0 ) 551 { 552 pos_end = setposcur(); 553 RemoveWordSET_0(fortran_out,pos_curinclude,pos_end-pos_curinclude); 554 } 555 } 344 556 | execution-part-construct 345 557 ; 346 347 fin_line : { pos_cur = setposcur(); } 348 ; 349 558 */ 559 560 fin_line: { pos_cur = setposcur(); } 561 ; 562 563 /* R202 : program-unit */ 564 program-unit: main-program 565 | external-subprogram 566 | module 567 ; 568 569 /*R203 : external-subprogram */ 570 external-subprogram: function-subprogram 571 | subroutine-subprogram 572 ; 573 350 574 opt_recursive : { isrecursive = 0; } 351 575 | TOK_RECURSIVE { isrecursive = 1; } … … 356 580 ; 357 581 358 entry : opt_recursive TOK_SUBROUTINE name_routine arglist359 {360 insubroutinedeclare = 1;361 if ( firstpass )362 Add_SubroutineArgument_Var_1($4);363 else364 WriteBeginof_SubLoop();365 }366 | TOK_PROGRAM name_routine367 {368 insubroutinedeclare = 1;369 inprogramdeclare = 1;370 /* in the second step we should write the head of */371 /* the subroutine sub_loop_<subroutinename> */372 if ( ! firstpass )373 WriteBeginof_SubLoop();374 }375 | opt_recursive TOK_FUNCTION name_routine arglist opt_result376 {377 insubroutinedeclare = 1;378 strcpy(DeclType, "");379 /* we should to list of the subroutine argument the */380 /* name of the function which has to be defined */381 if ( firstpass )382 {383 Add_SubroutineArgument_Var_1($4);384 if ( ! is_result_present )385 Add_FunctionType_Var_1($3);386 }387 else388 /* in the second step we should write the head of */389 /* the subroutine sub_loop_<subroutinename> */390 WriteBeginof_SubLoop();391 }392 | TOK_MODULE TOK_NAME393 {394 GlobalDeclaration = 0;395 strcpy(curmodulename,$2);396 strcpy(subroutinename,"");397 Add_NameOfModule_1($2);398 if ( inmoduledeclare == 0 )399 {400 /* To know if there are in the module declaration */401 inmoduledeclare = 1;402 /* to know if a module has been met */403 inmodulemeet = 1;404 /* to know if we are after the keyword contains */405 aftercontainsdeclare = 0 ;406 }407 }408 ;409 410 /* R312 : label */411 label: TOK_CSTINT412 | label TOK_CSTINT413 ;414 415 582 name_routine : TOK_NAME { strcpy($$, $1); strcpy(subroutinename, $1); } 416 583 ; … … 419 586 arglist : { if ( firstpass ) $$=NULL; } 420 587 | '(' ')' { if ( firstpass ) $$=NULL; } 421 | '(' args ')' { if ( firstpass ) $$=$2; }588 | '(' {in_complex_literal=0;} args ')' { if ( firstpass ) $$=$3; } 422 589 ; 423 590 arglist_after_result: 424 591 | '(' ')' 425 | '(' args ')' { if ( firstpass ) Add_SubroutineArgument_Var_1($2); }592 | '(' {in_complex_literal=0;} args ')' { if ( firstpass ) Add_SubroutineArgument_Var_1($3); } 426 593 ; 427 594 args : arg … … 452 619 | '*' { strcpy($$,"*"); } 453 620 ; 454 spec : type after_type 455 | TOK_TYPE opt_spec opt_sep opt_name { inside_type_declare = 1; } 456 | TOK_ENDTYPE opt_name { inside_type_declare = 0; } 457 | TOK_POINTER list_couple 458 | before_parameter '(' paramlist ')' 459 { 460 if ( ! inside_type_declare ) 461 { 462 if ( firstpass ) 463 { 464 if ( insubroutinedeclare ) Add_Parameter_Var_1($3); 465 else Add_GlobalParameter_Var_1($3); 466 } 467 else 468 { 469 pos_end = setposcur(); 470 RemoveWordSET_0(fortran_out, pos_cur_decl, pos_end-pos_cur_decl); 471 } 472 } 473 VariableIsParameter = 0 ; 474 } 475 | before_parameter paramlist 476 { 477 if ( ! inside_type_declare ) 478 { 479 if ( firstpass ) 480 { 481 if ( insubroutinedeclare ) Add_Parameter_Var_1($2); 482 else Add_GlobalParameter_Var_1($2); 483 } 484 else 485 { 486 pos_end = setposcur(); 487 RemoveWordSET_0(fortran_out,pos_cur_decl,pos_end-pos_cur_decl); 488 } 489 } 490 VariableIsParameter = 0 ; 491 } 492 | common 493 | save 494 { 495 pos_end = setposcur(); 496 RemoveWordSET_0(fortran_out,pos_cursave,pos_end-pos_cursave); 497 } 498 | implicit 499 | dimension 500 { 501 /* if the variable is a parameter we can suppose that is */ 502 /* value is the same on each grid. It is not useless to */ 503 /* create a copy of it on each grid */ 504 if ( ! inside_type_declare ) 505 { 506 if ( firstpass ) 507 { 508 Add_Globliste_1($1); 509 /* if variableparamlists has been declared in a subroutine */ 510 if ( insubroutinedeclare ) Add_Dimension_Var_1($1); 511 } 512 else 513 { 514 pos_end = setposcur(); 515 RemoveWordSET_0(fortran_out,pos_curdimension,pos_end-pos_curdimension); 516 } 517 } 518 PublicDeclare = 0; 519 PrivateDeclare = 0; 520 ExternalDeclare = 0; 521 strcpy(NamePrecision,""); 522 c_star = 0; 523 InitialValueGiven = 0 ; 524 strcpy(IntentSpec,""); 525 VariableIsParameter = 0 ; 526 Allocatabledeclare = 0 ; 527 Targetdeclare = 0 ; 528 SaveDeclare = 0; 529 pointerdeclare = 0; 530 optionaldeclare = 0 ; 531 dimsgiven=0; 532 c_selectorgiven=0; 533 strcpy(nameinttypename,""); 534 strcpy(c_selectorname,""); 535 } 536 | public 537 { 538 if (firstpass == 0) 539 { 540 if ($1) 541 { 542 removeglobfromlist(&($1)); 543 pos_end = setposcur(); 544 RemoveWordSET_0(fortran_out,pos_cur,pos_end-pos_cur); 545 writelistpublic($1); 546 } 547 } 548 } 549 | private 550 | use_stat 551 | module_proc_stmt 552 | namelist 553 | TOK_BACKSPACE '(' expr ')' 554 | TOK_EXTERNAL opt_sep use_name_list 555 | TOK_INTRINSIC opt_sep use_intrinsic_list 556 | TOK_EQUIVALENCE list_expr_equi 557 | data_stmt '\n' 558 { 559 /* we should remove the data declaration */ 560 pos_end = setposcur(); 561 RemoveWordSET_0(fortran_out,pos_curdata,pos_end-pos_curdata); 562 563 if ( aftercontainsdeclare == 1 && firstpass == 0 ) 564 { 565 ReWriteDataStatement_0(fortran_out); 566 pos_end = setposcur(); 567 } 568 } 569 ; 621 570 622 opt_spec : 571 623 | access_spec … … 619 671 | list_expr_equi1 ',' ident dims 620 672 ; 621 list_expr 673 list_expr: 622 674 expr 623 675 | list_expr ',' expr 624 676 ; 625 opt_sep 677 opt_sep: 626 678 | TOK_FOURDOTS 627 679 ; 628 after_type : 629 dcl nodimsgiven 630 { 631 /* if the variable is a parameter we can suppose that is*/ 632 /* value is the same on each grid. It is not useless */ 633 /* to create a copy of it on each grid */ 634 if ( ! inside_type_declare ) 635 { 636 pos_end = setposcur(); 637 RemoveWordSET_0(fortran_out,pos_cur_decl,pos_end-pos_cur_decl); 638 ReWriteDeclarationAndAddTosubroutine_01($1); 639 pos_cur_decl = setposcur(); 640 if ( firstpass == 0 && GlobalDeclaration == 0 641 && insubroutinedeclare == 0 ) 642 { 643 fprintf(fortran_out,"\n#include \"Module_Declar_%s.h\"\n", curmodulename); 644 sprintf(ligne, "Module_Declar_%s.h", curmodulename); 645 module_declar = open_for_write(ligne); 646 GlobalDeclaration = 1 ; 647 pos_cur_decl = setposcur(); 648 } 649 $$ = $1; 650 651 if ( firstpass ) 652 { 653 Add_Globliste_1($1); 654 if ( insubroutinedeclare ) 655 { 656 if ( pointerdeclare ) Add_Pointer_Var_From_List_1($1); 657 Add_Parameter_Var_1($1); 658 } 659 else 660 Add_GlobalParameter_Var_1($1); 661 662 /* If there's a SAVE declaration in module's subroutines we should */ 663 /* remove it from the subroutines declaration and add it in the */ 664 /* global declarations */ 665 if ( aftercontainsdeclare && SaveDeclare ) 666 { 667 if ( inmodulemeet ) Add_SubroutineDeclarationSave_Var_1($1); 668 else Add_Save_Var_dcl_1($1); 669 } 670 } 671 } 672 else 673 { 674 $$ = (listvar *) NULL; 675 } 676 PublicDeclare = 0; 677 PrivateDeclare = 0; 678 ExternalDeclare = 0; 679 strcpy(NamePrecision,""); 680 c_star = 0; 681 InitialValueGiven = 0 ; 682 strcpy(IntentSpec,""); 683 VariableIsParameter = 0 ; 684 Allocatabledeclare = 0 ; 685 Targetdeclare = 0 ; 686 SaveDeclare = 0; 687 pointerdeclare = 0; 688 optionaldeclare = 0 ; 689 dimsgiven=0; 690 c_selectorgiven=0; 691 strcpy(nameinttypename,""); 692 strcpy(c_selectorname,""); 693 GlobalDeclarationType = 0; 694 } 695 | before_function name_routine arglist 696 { 697 insubroutinedeclare = 1; 698 699 if ( firstpass ) 700 { 701 Add_SubroutineArgument_Var_1($3); 702 Add_FunctionType_Var_1($2); 703 } 704 else 705 WriteBeginof_SubLoop(); 706 707 strcpy(nameinttypename,""); 708 } 709 ; 680 710 681 before_function : TOK_FUNCTION { functiondeclarationisdone = 1; } 711 682 ; 712 before_parameter : TOK_PARAMETER { 683 before_parameter : TOK_PARAMETER {VariableIsParameter = 1; pos_curparameter = setposcur()-9; } 713 684 ; 714 685 … … 750 721 ; 751 722 752 save 723 save: before_save varsave 753 724 | before_save comblock varsave 754 725 | save opt_comma comblock opt_comma varsave 755 726 | save ',' varsave 756 727 ; 757 before_save 728 before_save: 758 729 TOK_SAVE { pos_cursave = setposcur()-4; } 759 730 ; … … 896 867 strcpy(curvar->v_subroutinename,subroutinename); 897 868 strcpy(curvar->v_modulename,curmodulename); 898 strcpy(curvar->v_initialvalue,$3);869 curvar->v_initialvalue=Insertname(curvar->v_initialvalue,$3,0); 899 870 strcpy(curvar->v_commoninfile,cur_filename); 900 871 Save_Length($3,14); … … 919 890 } 920 891 } 921 | TOK_IMPLICIT TOK_REAL8 922 ; 923 dcl : options TOK_NAME dims lengspec initial_value 892 ; 893 dcl: options TOK_NAME dims lengspec initial_value 924 894 { 925 895 if ( ! inside_type_declare ) … … 970 940 nodimsgiven : { dimsgiven = 0; } 971 941 ; 972 type : typespec selector { strcpy(DeclType,$1);}942 type: typespec selector { strcpy(DeclType,$1);} 973 943 | before_character c_selector { strcpy(DeclType,"character"); } 974 944 | typespec '*' TOK_CSTINT { strcpy(DeclType,$1); strcpy(nameinttypename,$3); } … … 993 963 | TOK_COMPLEX { strcpy($$,"complex"); pos_cur_decl = setposcur()-7; } 994 964 | TOK_DOUBLECOMPLEX { strcpy($$,"double complex"); pos_cur_decl = setposcur()-14; } 995 | TOK_DOUBLEPRECISION { pos_cur_decl = setposcur()-16; strcpy($$,"real"); strcpy(nameinttypename,"8"); }965 | TOK_DOUBLEPRECISION { pos_cur_decl = setposcur()-16; strcpy($$,"real"); strcpy(nameinttypename,"8"); printf("OK1\n");} 996 966 ; 997 967 lengspec : … … 1033 1003 | ',' TOK_NAME clause 1034 1004 ; 1035 options 1005 options: 1036 1006 | TOK_FOURDOTS 1037 1007 | ',' attr_spec_list TOK_FOURDOTS 1038 1008 ; 1039 attr_spec_list 1009 attr_spec_list: attr_spec 1040 1010 | attr_spec_list ',' attr_spec 1041 1011 ; … … 1047 1017 | TOK_EXTERNAL { ExternalDeclare = 1; } 1048 1018 | TOK_INTENT '(' intent_spec ')' 1049 { strcpy(IntentSpec,$3); }1019 { strcpy(IntentSpec,$3); intent_spec = 0;} 1050 1020 | TOK_INTRINSIC 1051 1021 | TOK_OPTIONAL { optionaldeclare = 1 ; } … … 1064 1034 ; 1065 1035 dims : { $$ = (listdim*) NULL; } 1066 | '(' dimlist ')'1036 | '(' {in_complex_literal=0;} dimlist ')' 1067 1037 { 1068 1038 $$ = (listdim*) NULL; 1069 1039 if ( inside_type_declare ) break; 1070 if ( created_dimensionlist == 1 || agrif_parentcall == 1 ) $$=$ 2;1040 if ( created_dimensionlist == 1 || agrif_parentcall == 1 ) $$=$3; 1071 1041 } 1072 1042 ; … … 1095 1065 | expr { strcpy($$,$1); } 1096 1066 ; 1097 expr : uexpr { strcpy($$,$1); } 1067 /* 1068 expr: uexpr { strcpy($$,$1); } 1098 1069 | complex_const { strcpy($$,$1); } 1099 1070 | predefinedfunction { strcpy($$,$1); } 1100 1071 | '(' expr ')' { sprintf($$,"(%s)",$2); } 1101 1072 ; 1102 1073 */ 1103 1074 predefinedfunction : 1104 1075 TOK_SUM minmaxlist ')' { sprintf($$,"SUM(%s)",$2);} … … 1134 1105 uexpr : lhs { strcpy($$,$1); } 1135 1106 | simple_const { strcpy($$,$1); } 1136 | vec { strcpy($$,$1); }1137 1107 | expr operation { sprintf($$,"%s%s",$1,$2); } 1138 1108 | signe expr %prec '*' { sprintf($$,"%s%s",$1,$2); } … … 1195 1165 begin_array { strcpy($$,$1); if ( incalldeclare == 0 ) inagrifcallargument = 0; } 1196 1166 | begin_array substring { sprintf($$," %s %s ",$1,$2); } 1197 | structure_component '(' funarglist ')' { sprintf($$," %s ( %s )",$1,$3); }1198 | structure_component '(' funarglist ')' substring { sprintf($$," %s ( %s ) %s ",$1,$3,$5); }1199 ; 1200 begin_array : 1201 ident '('funarglist ')'1167 | structure_component '(' {in_complex_literal=0;} funarglist ')' { sprintf($$," %s ( %s )",$1,$4); } 1168 | structure_component '(' {in_complex_literal=0;} funarglist ')' substring { sprintf($$," %s ( %s ) %s ",$1,$4,$6); } 1169 ; 1170 begin_array : TOK_LOGICALIF 1171 | ident '(' {in_complex_literal=0;} funarglist ')' 1202 1172 { 1203 1173 if ( inside_type_declare ) break; 1204 sprintf($$," %s ( %s )",$1,$ 3);1205 ModifyTheAgrifFunction_0($ 3);1174 sprintf($$," %s ( %s )",$1,$4); 1175 ModifyTheAgrifFunction_0($4); 1206 1176 agrif_parentcall = 0; 1207 1177 } … … 1214 1184 } 1215 1185 ; 1186 /* 1216 1187 vec : 1217 1188 TOK_LEFTAB outlist TOK_RIGHTAB { sprintf($$,"(/%s/)",$2); } 1218 1189 ; 1190 */ 1219 1191 funarglist : 1220 1192 beforefunctionuse { strcpy($$," "); } … … 1238 1210 | ':' { sprintf($$,":");} 1239 1211 ; 1240 ident : TOK_NAME 1241 { 1212 ident: TOK_NAME 1213 { 1214 // if (indeclaration == 1) break; 1242 1215 if ( afterpercent == 0 ) 1243 1216 { … … 1303 1276 | substring { strcpy($$,$1);} 1304 1277 ; 1278 /* 1305 1279 substring : 1306 1280 '(' optexpr ':' optexpr ')' { sprintf($$,"(%s :%s)",$2,$4);} 1307 1281 ; 1282 */ 1308 1283 optexpr : { strcpy($$," ");} 1309 1284 | expr { strcpy($$,$1);} 1310 1285 ; 1311 opt_expr : 1312 '\n' { strcpy($$," ");} 1286 opt_expr : { strcpy($$," ");} 1313 1287 | expr { strcpy($$,$1);} 1314 1288 ; 1315 initial_value 1289 initial_value: { InitialValueGiven = 0; } 1316 1290 | '=' expr 1317 1291 { … … 1330 1304 '(' uexpr ',' uexpr ')' {sprintf($$,"(%s,%s)",$2,$4); } 1331 1305 ; 1332 use_stat : 1333 word_use TOK_NAME 1334 { 1335 /* if variables has been declared in a subroutine */ 1336 sprintf(charusemodule, "%s", $2); 1337 if ( firstpass ) 1338 { 1339 Add_NameOfModuleUsed_1($2); 1306 1307 only_list : 1308 only_name { $$ = $1; } 1309 | only_list ',' only_name 1310 { 1311 /* insert the variable in the list $1 */ 1312 $3->suiv = $1; 1313 $$ = $3; 1314 } 1315 ; 1316 only_name : 1317 TOK_NAME TOK_POINT_TO TOK_NAME 1318 { 1319 coupletmp = (listcouple *)calloc(1,sizeof(listcouple)); 1320 strcpy(coupletmp->c_namevar,$1); 1321 strcpy(coupletmp->c_namepointedvar,$3); 1322 coupletmp->suiv = NULL; 1323 $$ = coupletmp; 1324 pointedvar = 1; 1325 Add_UsedInSubroutine_Var_1($1); 1326 } 1327 | TOK_NAME 1328 { 1329 coupletmp = (listcouple *)calloc(1,sizeof(listcouple)); 1330 strcpy(coupletmp->c_namevar,$1); 1331 strcpy(coupletmp->c_namepointedvar,""); 1332 coupletmp->suiv = NULL; 1333 $$ = coupletmp; 1334 } 1335 ; 1336 1337 /* R204 : specification-part */ 1338 /* opt-implicit-part removed but implicit-stmt and format-stmt added to declaration-construct */ 1339 specification-part: opt-use-stmt-list opt-declaration-construct-list 1340 ; 1341 1342 opt-use-stmt-list: 1343 |use-stmt-list 1344 ; 1345 1346 opt-implicit-part: 1347 |implicit-part 1348 ; 1349 1350 implicit-part: opt-implicit-part-stmt-list implicit-stmt 1351 ; 1352 1353 opt-implicit-part-stmt-list: 1354 | implicit-part-stmt-list 1355 ; 1356 1357 implicit-part-stmt-list: implicit-part-stmt 1358 | implicit-part-stmt-list implicit-part-stmt 1359 ; 1360 1361 /* R206: implicit-part-stmt */ 1362 implicit-part-stmt: implicit-stmt 1363 | parameter-stmt 1364 | format-stmt 1365 ; 1366 1367 1368 opt-declaration-construct-list: 1369 |declaration-construct-list 1370 ; 1371 1372 declaration-construct-list: 1373 declaration-construct 1374 | declaration-construct-list declaration-construct 1375 ; 1376 1377 /* R207 : declaration-construct */ 1378 /* stmt-function-stmt replaced by assignment-stmt due to reduce conflicts */ 1379 /* because assignment-stmt has been added */ 1380 /* Every statement that begins with a variable should be added */ 1381 /* This include : */ 1382 /* pointer-assignment-stmt, do-construct */ 1383 /* implicit-stmt and format-stmt added since implicit-part-stmt has been removed due to conflicts (see R204) */ 1384 /* ANOTHER SOLUTION TO THE PROBLEM OF STMT-FUNCTION IS NEEDED !!!! */ 1385 /* BECAUSE ALMOST ALL ACTION-STMT SHOULD BE INCLUDED HERE !!! */ 1386 1387 declaration-construct: derived-type-def 1388 | parameter-stmt 1389 | format-stmt 1390 | implicit-stmt 1391 | other-specification-stmt 1392 | type-declaration-stmt 1393 | assignment-stmt 1394 | pointer-assignment-stmt 1395 | do-construct 1396 | if-construct 1397 | continue-stmt 1398 | return-stmt 1399 | print-stmt 1400 ; 1401 1402 opt-execution-part: 1403 | execution-part 1404 ; 1405 1406 /* R208 : execution-part */ 1407 execution-part: executable-construct opt-execution-part-construct-list 1408 ; 1409 1410 opt-execution-part-construct-list: 1411 |execution-part-construct-list 1412 ; 1413 1414 execution-part-construct-list: 1415 execution-part-construct 1416 | execution-part-construct-list execution-part-construct 1417 ; 1418 1419 /* R209 : execution-part-construct */ 1420 execution-part-construct: executable-construct 1421 | format-stmt 1422 ; 1423 1424 opt-internal-subprogram-part: 1425 | internal-subprogram-part 1426 ; 1427 1428 /* R120 : internal-subprogram-part */ 1429 internal-subprogram-part: TOK_CONTAINS line-break 1430 opt-internal-subprogram 1431 ; 1432 1433 opt-internal-subprogram: 1434 | internal-subprogram-list 1435 ; 1436 1437 internal-subprogram-list: internal-subprogram 1438 | internal-subprogram-list internal-subprogram 1439 ; 1440 1441 /* R211 : internal-subprogram */ 1442 internal-subprogram: function-subprogram 1443 | subroutine-subprogram 1444 ; 1445 1446 /* R212 : other-specification-stmt */ 1447 other-specification-stmt: access-stmt 1448 | common-stmt 1449 | data-stmt 1450 | dimension-stmt 1451 | equivalence-stmt 1452 | external-stmt 1453 | intrinsic-stmt 1454 | namelist-stmt 1455 | save-stmt 1456 ; 1457 1458 /* R213 : executable-construct */ 1459 executable-construct: 1460 action-stmt 1461 | do-construct 1462 | case-construct 1463 | if-construct 1464 | where-construct 1465 ; 1466 1467 /* R214 : action-stmt */ 1468 1469 /* normal action-stmt */ 1470 1471 action-stmt: 1472 allocate-stmt 1473 | assignment-stmt 1474 | call-stmt 1475 | close-stmt 1476 | continue-stmt 1477 | cycle-stmt 1478 | deallocate-stmt 1479 | goto-stmt 1480 | exit-stmt 1481 | flush-stmt 1482 | TOK_CYCLE opt_expr 1483 | TOK_NULLIFY '(' pointer_name_list ')' 1484 | TOK_ENDMODULE opt_name 1485 { 1486 /* if we never meet the contains keyword */ 1487 if ( firstpass == 0 ) 1488 { 1489 RemoveWordCUR_0(fortran_out, strlen($2)+11); // Remove word "end module" 1490 if ( inmoduledeclare && ! aftercontainsdeclare ) 1491 { 1492 Write_Closing_Module(1); 1493 } 1494 fprintf(fortran_out,"\n end module %s\n", curmodulename); 1495 if ( module_declar && insubroutinedeclare == 0 ) 1496 { 1497 fclose(module_declar); 1498 } 1499 } 1500 inmoduledeclare = 0 ; 1501 inmodulemeet = 0 ; 1502 aftercontainsdeclare = 1; 1503 strcpy(curmodulename, ""); 1504 GlobalDeclaration = 0 ; 1505 } 1506 | if-stmt 1507 | inquire-stmt 1508 | open-stmt 1509 | pointer-assignment-stmt 1510 | print-stmt 1511 | read-stmt 1512 | return-stmt 1513 | rewind-stmt 1514 | stop-stmt 1515 | where-stmt 1516 | write-stmt 1517 | arithmetic-if-stmt 1518 ; 1519 1520 /* R215 : keyword */ 1521 keyword: ident 1522 ; 1523 1524 scalar-constant: constant 1525 ; 1526 1527 /* R304 : constant */ 1528 1529 constant: literal-constant 1530 | named-constant 1531 ; 1532 1533 /* R305 : literal-constant */ 1534 literal-constant: int-literal-constant 1535 | real-literal-constant 1536 | logical-literal-constant 1537 | complex-literal-constant 1538 {in_complex_literal=0;} 1539 | char-literal-constant 1540 ; 1541 1542 /* R306 : named-constant */ 1543 named-constant: ident 1544 ; 1545 1546 scalar-int-constant:int-constant 1547 ; 1548 1549 /* R307 : int-constant */ 1550 int-constant: int-literal-constant 1551 | named-constant 1552 ; 1553 1554 /* 1555 constant: TOK_CSTINT 1556 | TOK_CSTREAL 1557 | ident 1558 ; 1559 */ 1560 1561 opt-label: 1562 {strcpy($$,"");} 1563 | label 1564 ; 1565 1566 /* R312 : label */ 1567 label: TOK_LABEL 1568 | TOK_CSTINT 1569 ; 1570 1571 opt-label-djview: 1572 {strcpy($$,"");} 1573 | label-djview 1574 {strcpy($$,$1);} 1575 ; 1576 1577 label-djview: TOK_LABEL_DJVIEW 1578 ; 1579 1580 /* R401 : type-param-value */ 1581 type-param-value: scalar-int-expr 1582 | '*' 1583 | ':' 1584 ; 1585 1586 /* R402: type-spec */ 1587 type-spec: intrinsic-type-spec 1588 {strcpy($$,$1);} 1589 | derived-type-spec 1590 {strcpy($$,$1);} 1591 ; 1592 1593 /* R403 : declaration-type-spec */ 1594 declaration-type-spec: {pos_cur_decl=my_position_before;} intrinsic-type-spec 1595 {strcpy($$,$2);} 1596 | TOK_TYPEPAR intrinsic-type-spec ')' 1597 | TOK_TYPEPAR derived-type-spec ')' 1598 {strcpy(DeclType,"type"); GlobalDeclarationType = 1; } 1599 ; 1600 1601 /* R404 : intrinsic-type-spec */ 1602 intrinsic-type-spec: TOK_INTEGER {in_kind_selector = 1;} opt-kind-selector 1603 {sprintf($$,"%s%s",$1,$[opt-kind-selector]);strcpy(DeclType,$1); in_kind_selector =0;} 1604 | TOK_REAL {in_kind_selector = 1;} opt-kind-selector 1605 {sprintf($$,"%s%s",$1,$[opt-kind-selector]);strcpy(DeclType,$1);in_kind_selector =0;} 1606 | TOK_DOUBLEPRECISION {in_kind_selector = 1;} opt-kind-selector 1607 {sprintf($$,"%s%s",$1,$[opt-kind-selector]);strcpy(DeclType,"real"); strcpy(NamePrecision,"8");in_kind_selector =0;} 1608 | TOK_COMPLEX {in_kind_selector = 1;} opt-kind-selector 1609 {sprintf($$,"%s%s",$1,$[opt-kind-selector]);strcpy(DeclType,$1);in_kind_selector =0;} 1610 | TOK_CHARACTER {in_char_selector = 1;} opt-char-selector 1611 {sprintf($$,"%s%s",$1,$[opt-char-selector]);strcpy(DeclType,$1);in_char_selector = 0;} 1612 | TOK_LOGICAL {in_kind_selector = 1;} opt-kind-selector 1613 {sprintf($$,"%s%s",$1,$[opt-kind-selector]);strcpy(DeclType,$1);in_kind_selector =0;} 1614 ; 1615 1616 opt-kind-selector: 1617 {strcpy($$,"");strcpy(NamePrecision,"");} 1618 |kind-selector 1619 {strcpy($$,$1);} 1620 ; 1621 1622 /* R405 : kind-selector */ 1623 /* Nonstandard extension : * INT */ 1624 kind-selector: '(' scalar-int-constant-expr ')' 1625 {sprintf($$,"(%s)",$2); strcpy(NamePrecision,$2);} 1626 | '(' TOK_KIND '=' scalar-int-constant-expr ')' 1627 {sprintf($$,"(KIND=%s)",$4); strcpy(NamePrecision,$4);} 1628 | '*' TOK_CSTINT <