From 0baa3df08da8bfeb8be1fe1c13755e1a9938c46c Mon Sep 17 00:00:00 2001 From: jcwarner-USGS Date: Wed, 10 Jul 2024 09:26:12 -0400 Subject: [PATCH 1/9] update scrip remap conserv --- model/src/SCRIP/scrip_remap_conservative.f | 581 ++++++++++++++++++++- 1 file changed, 579 insertions(+), 2 deletions(-) diff --git a/model/src/SCRIP/scrip_remap_conservative.f b/model/src/SCRIP/scrip_remap_conservative.f index 4bbc748c8..ede23706e 100644 --- a/model/src/SCRIP/scrip_remap_conservative.f +++ b/model/src/SCRIP/scrip_remap_conservative.f @@ -252,6 +252,8 @@ subroutine remap_conserv(l_master, l_test) ! !----------------------------------------------------------------------- + USE W3ADATMD, ONLY: MPI_COMM_WAVE + logical(SCRIP_Logical), intent(in) :: l_master ! Am I the master ! processor (do I/O)? logical(SCRIP_Logical), intent(in) :: l_test ! Whether to @@ -262,6 +264,19 @@ subroutine remap_conserv(l_master, l_test) ! local variables ! !----------------------------------------------------------------------- +!#ifdef W3_SCRIP_JCW + include 'mpif.h' + integer (SCRIP_i4) :: MyStr, MyEnd, MyComm + integer (SCRIP_i4) :: MyError, MyRank, Nprocs, rank + integer (SCRIP_i4) :: ratio + integer (SCRIP_i4) :: j, ij, add1, add2, got_weight + integer (SCRIP_i4) :: nlink, min_link, max_link + integer (SCRIP_i4), dimension(MPI_STATUS_SIZE) :: status + integer (SCRIP_i4), dimension(:), allocatable :: Numlinks + integer (SCRIP_i4), dimension(:), allocatable :: Asendi + integer (SCRIP_i4), dimension(:), allocatable :: Arecv1 + integer (SCRIP_i4), dimension(:), allocatable :: Arecv2 +!#endif integer (SCRIP_i4), parameter :: & phi_or_theta = 2 ! integrate w.r.t. phi (1) or theta (2) @@ -301,6 +316,12 @@ subroutine remap_conserv(l_master, l_test) ! and true area & ref_area ! Area of cell as computed by direct ! integration around its boundaries +!#ifdef W3_SCRIP_JCW + real (SCRIP_r8), dimension(:), allocatable :: Asend + real (SCRIP_r8), dimension(:), allocatable :: Arecvw + real (SCRIP_r8), dimension(:), allocatable :: Arecv + real (SCRIP_r8), dimension(:,:), allocatable :: Arecvw2d +!#endif ! call OMP_SET_DYNAMIC(.FALSE.) @@ -337,7 +358,28 @@ subroutine remap_conserv(l_master, l_test) C$OMP DO SCHEDULE(DYNAMIC) - do grid1_add = 1,grid1_size + +!#ifdef W3_SCRIP_JCW + MyComm=MPI_COMM_WAVE + CALL mpi_comm_rank (MyComm, MyRank, MyError) + CALL mpi_comm_size (MyComm, Nprocs, MyError) +! +! To do this in mpi, we will just break up the sweep loops into chunks. Then +! gather all of the data at end of each loop so that each proc has a full set of +! data. First we want to determine start and end chunks for this processor. +! + IF (Nprocs.eq.1) THEN + MyStr=1 + MyEnd=grid1_size + ELSE + ratio=INT(grid1_size/Nprocs) + MyStr=(MyRank*ratio)+1 + MyEnd=MyStr+ratio-1 + IF (MyRank+1.eq.Nprocs) MyEnd=grid1_size + END IF + +!jcw do grid1_add = 1,grid1_size + do grid1_add = MyStr,MyEnd if (mod(grid1_add,progint) .eq. 0 .and. is_master) then print *, grid1_add,' of ',grid1_size,' cells processed ...' @@ -351,6 +393,107 @@ subroutine remap_conserv(l_master, l_test) C$OMP END PARALLEL + +!#ifdef W3_SCRIP_JCW +! +! Here we need to gather all the data to each proc so they know the +! full data set. +! +! first_call +! + allocate (Asend(grid1_size)) + allocate (Arecv(grid1_size)) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Work on grid1_frac(grid1_size) +! zero it out. + DO grid1_add=1,grid1_size + Asend(grid1_add)=zero + Arecv(grid1_add)=zero + END DO +! fill the send for this tile. + DO grid1_add=MyStr,MyEnd + Asend(grid1_add)=grid1_frac(grid1_add) + END DO + call mpi_allreduce(Asend, Arecv, grid1_size, MPI_DOUBLE, & + & MPI_SUM, MyComm, MyError) +! fill the working array as a sum from all nodes. + DO grid1_add=1,grid1_size + grid1_frac(grid1_add)=Arecv(grid1_add) + END DO +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Work on grid1_area(grid1_size) +! zero it out. + DO grid1_add=1,grid1_size + Asend(grid1_add)=zero + Arecv(grid1_add)=zero + END DO +! fill the send for this tile. + DO grid1_add=MyStr,MyEnd + Asend(grid1_add)=grid1_area(grid1_add) + END DO + call mpi_allreduce(Asend, Arecv, grid1_size, MPI_DOUBLE, & + & MPI_SUM, MyComm, MyError) +! fill the working array as a sum from all nodes. + DO grid1_add=1,grid1_size + grid1_area(grid1_add)=Arecv(grid1_add) + END DO +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Work on grid1_centroid_lat(grid1_size) +! zero it out. + DO grid1_add=1,grid1_size + Asend(grid1_add)=zero + Arecv(grid1_add)=zero + END DO +! fill the send for this tile. + DO grid1_add=MyStr,MyEnd + Asend(grid1_add)=grid1_centroid_lat(grid1_add) + END DO + call mpi_allreduce(Asend, Arecv, grid1_size, MPI_DOUBLE, & + & MPI_SUM, MyComm, MyError) +! fill the working array as a sum from all nodes. + DO grid1_add=1,grid1_size + grid1_centroid_lat(grid1_add)=Arecv(grid1_add) + END DO +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Work on grid1_centroid_lon(grid1_size) +! zero it out. + DO grid1_add=1,grid1_size + Asend(grid1_add)=zero + Arecv(grid1_add)=zero + END DO +! fill the send for this tile. + DO grid1_add=MyStr,MyEnd + Asend(grid1_add)=grid1_centroid_lon(grid1_add) + END DO + call mpi_allreduce(Asend, Arecv, grid1_size, MPI_DOUBLE, & + & MPI_SUM, MyComm, MyError) +! fill the working array as a sum from all nodes. + DO grid1_add=1,grid1_size + grid1_centroid_lon(grid1_add)=Arecv(grid1_add) + END DO + deallocate(Asend, Arecv) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + allocate (Asend(grid2_size)) + allocate (Arecv(grid2_size)) +! Work on grid2_frac(grid2_size) +! zero it out. + DO grid2_add=1,grid2_size + Asend(grid2_add)=zero + Arecv(grid2_add)=zero + END DO +! fill the send for this tile. + DO grid2_add=1,grid2_size + Asend(grid2_add)=grid2_frac(grid2_add) + END DO + call mpi_allreduce(Asend, Arecv, grid2_size, MPI_DOUBLE, & + & MPI_SUM, MyComm, MyError) +! fill the working array as a sum from all nodes. + DO grid2_add=1,grid2_size + grid2_frac(grid2_add)=Arecv(grid2_add) + END DO + deallocate(Asend, Arecv) +!#endif + !----------------------------------------------------------------------- ! ! integrate around each cell on grid2 @@ -380,7 +523,24 @@ subroutine remap_conserv(l_master, l_test) C$OMP DO SCHEDULE(DYNAMIC) - do grid2_add = 1,grid2_size +!#ifdef W3_SCRIP_JCW +! +! To do this in mpi, we will just break up the sweep loops into chunks. Then +! gather all of the data at end of each loop so that each proc has a full set of +! data. First we want to determine start and end chunks for this processor. +! + IF (Nprocs.eq.1) THEN + MyStr=1 + MyEnd=grid2_size + ELSE + ratio=INT(grid2_size/Nprocs) + MyStr=(MyRank*ratio)+1 + MyEnd=MyStr+ratio-1 + IF (MyRank+1.eq.Nprocs) MyEnd=grid2_size + END IF + +!jcw do grid2_add = 1,grid2_size + do grid2_add = MyStr,MyEnd if (mod(grid2_add,progint) .eq. 0 .and. is_master) then print *, grid2_add,' of ',grid2_size,' cells processed ...' @@ -396,6 +556,423 @@ subroutine remap_conserv(l_master, l_test) call timer_stop(2) + +!#ifdef W3_SCRIP_JCW +! +! Here we need to gather all the data to each proc so they know the +! full data set. +! +! second_call +! + allocate (Asend(grid2_size)) + allocate (Arecv(grid2_size)) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Work on grid2_frac(grid2_size) +! zero it out. + DO grid2_add=1,grid2_size + Asend(grid2_add)=zero + Arecv(grid2_add)=zero + END DO +! fill the send for this tile. + DO grid2_add=MyStr,MyEnd + Asend(grid2_add)=grid2_frac(grid2_add) + END DO + call mpi_allreduce(Asend, Arecv, grid2_size, MPI_DOUBLE, & + & MPI_SUM, MyComm, MyError) +! fill the working array as a sum from all nodes. + DO grid2_add=1,grid2_size + grid2_frac(grid2_add)=Arecv(grid2_add) + END DO +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Work on grid2_area(grid2_size) +! zero it out. + DO grid2_add=1,grid2_size + Asend(grid2_add)=zero + Arecv(grid2_add)=zero + END DO +! fill the send for this tile. + DO grid2_add=MyStr,MyEnd + Asend(grid2_add)=grid2_area(grid2_add) + END DO + call mpi_allreduce(Asend, Arecv, grid2_size, MPI_DOUBLE, & + & MPI_SUM, MyComm, MyError) +! fill the working array as a sum from all nodes. + DO grid2_add=1,grid2_size + grid2_area(grid2_add)=Arecv(grid2_add) + END DO +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Work on grid2_centroid_lat(grid2_size) +! zero it out. + DO grid2_add=1,grid2_size + Asend(grid2_add)=zero + Arecv(grid2_add)=zero + END DO +! fill the send for this tile. + DO grid2_add=MyStr,MyEnd + Asend(grid2_add)=grid2_centroid_lat(grid2_add) + END DO + call mpi_allreduce(Asend, Arecv, grid2_size, MPI_DOUBLE, & + & MPI_SUM, MyComm, MyError) +! fill the working array as a sum from all nodes. + DO grid2_add=1,grid2_size + grid2_centroid_lat(grid2_add)=Arecv(grid2_add) + END DO +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Work on grid2_centroid_lon(grid2_size) +! zero it out. + DO grid2_add=1,grid2_size + Asend(grid2_add)=zero + Arecv(grid2_add)=zero + END DO +! fill the send for this tile. + DO grid2_add=MyStr,MyEnd + Asend(grid2_add)=grid2_centroid_lon(grid2_add) + END DO + call mpi_allreduce(Asend, Arecv, grid2_size, MPI_DOUBLE, & + & MPI_SUM, MyComm, MyError) +! fill the working array as a sum from all nodes. + DO grid2_add=1,grid2_size + grid2_centroid_lon(grid2_add)=Arecv(grid2_add) + END DO + deallocate(Asend, Arecv) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + allocate (Asend(grid1_size)) + allocate (Arecv(grid1_size)) +! Work on grid1_frac(grid1_size) +! zero it out. + DO grid1_add=1,grid1_size + Asend(grid1_add)=zero + Arecv(grid1_add)=zero + END DO +! fill the send for this tile. + DO grid1_add=1,grid1_size + Asend(grid1_add)=grid1_frac(grid1_add) + END DO + call mpi_allreduce(Asend, Arecv, grid1_size, MPI_DOUBLE, & + & MPI_SUM, MyComm, MyError) +! fill the working array as a sum from all nodes. + DO grid1_add=1,grid1_size + grid1_frac(grid1_add)=Arecv(grid1_add) + END DO + deallocate(Asend, Arecv) +!#endif + + + + + +!#ifdef W3_SCRIP_JCW +! +! Here we need to gather all the data that was computed in +! store_link_cnsrv. +! +! gather total number of links that were computed on each processor. +! + allocate(Numlinks(Nprocs)) + call mpi_gather(num_links_map1, 1, MPI_INT, Numlinks, 1, MPI_INT, & + & 0, MyComm, MyError) +! +! Now gather all the weights from other nodes to make one combined set. +! + IF (MyRank.ne.0) THEN + allocate (Asendi(num_links_map1)) + Asendi=0 +! + DO i=1,num_links_map1 + Asendi(i)=grid1_add_map1(i) + END DO + call mpi_send(Asendi, num_links_map1, MPI_INT, 0, & + & 10, MyComm, MyError) +! + Asendi(1:num_links_map1)=grid2_add_map1(1:num_links_map1) + call mpi_send(Asendi, num_links_map1, MPI_INT, 0, & + & 20, MyComm, MyError) +! + deallocate (Asendi) + allocate (Asend(num_links_map1*num_wts)) + Asend=0 +! + ij=0 + DO i=1,num_links_map1 + DO j=1,num_wts + ij=ij+1 + Asend(ij)=wts_map1(j,i) + END DO + END DO + call mpi_send(Asend, num_links_map1*num_wts, MPI_DOUBLE, 0, & + & 30, MyComm, MyError) + deallocate (Asend) + ELSE ! we are on the Master + + + DO i=2,Nprocs + allocate (Arecv1(Numlinks(i))) !grid1_add_map1 + allocate (Arecv2(Numlinks(i))) !grid2_add_map1 + allocate (Arecvw(num_wts*Numlinks(i))) !wts_map1 + allocate (Arecvw2d(num_wts,Numlinks(i))) !wts_map1 + Arecv1=0 + Arecv2=0 + Arecvw=zero + Arecvw2d=zero +! +! Receiving grid1 area. +! + call mpi_recv(Arecv1, Numlinks(i), MPI_INT, i-1, 10, & + & MyComm, status, MyError) +! +! Receiving grid2 area. +! + call mpi_recv(Arecv2, Numlinks(i), MPI_INT, i-1, 20, & + & MyComm, status, MyError) +! +! Receiving weights +! + call mpi_recv(Arecvw, Numlinks(i)*num_wts, MPI_DOUBLE,i-1,30, & + & MyComm, status, MyError) + ij=0 + DO nlink=1,Numlinks(i) + DO j=1,num_wts + ij=ij+1 + Arecvw2d(j,nlink)=Arecvw(ij) + END DO + END DO +!----------------------------------------------------------------------- +! +! if the link already exists, add the weight to the current weight +! arrays +! +!----------------------------------------------------------------------- + do nlink=1,Numlinks(i) + add1=Arecv1(nlink) + add2=Arecv2(nlink) + got_weight=0 +! + min_link = min(link_add1(1,add1),link_add2(1,add2)) + max_link = max(link_add1(2,add1),link_add2(2,add2)) + if (min_link == 0) then + min_link = 1 + max_link = 0 + endif + do j=min_link,max_link + if (add1 == grid1_add_map1(j)) then + if (add2 == grid2_add_map1(j)) then + wts_map1(:,j)=wts_map1(:,j)+Arecvw2d(1:num_wts,nlink) + got_weight=1 + endif + endif + end do +!----------------------------------------------------------------------- +! +! if the link does not yet exist, increment number of links and +! check to see if remap arrays need to be increased to accomodate +! the new link. then store the link. +! +!----------------------------------------------------------------------- + if (got_weight.eq.0) then + num_links_map1 = num_links_map1 + 1 + if (num_links_map1 > max_links_map1) & + & call resize_remap_vars(1,max_links_map1-num_links_map1) +! & call resize_remap_vars(1,resize_increment) + grid1_add_map1(num_links_map1) = add1 + grid2_add_map1(num_links_map1) = add2 + wts_map1 (:,num_links_map1) = Arecvw2d(1:num_wts,nlink) + END IF + + if (link_add1(1,add1) == 0) link_add1(1,add1)=num_links_map1 + if (link_add2(1,add2) == 0) link_add2(1,add2)=num_links_map1 + link_add1(2,add1) = num_links_map1 + link_add2(2,add2) = num_links_map1 + + END DO + deallocate (Arecv1, Arecv2, Arecvw, Arecvw2d) + END DO + END IF + +! +! Now distribute: num_links_map1, , max_links_map1 +! grid1_add_map1, grid2_add_map1, wts_map1, +! link_add1, link_add2 +! +! send num_links_map1 +! + call mpi_bcast(num_links_map1, 1, MPI_INT, & + & 0, MyComm, MyError) +! force this + max_links_map1=num_links_map1 + call mpi_barrier(MyComm, MyError) +! +! here we do what is in resize_remap_vars and just make the +! sizes of grid1_add_map1, grid2_add_map1, and wts_map1 to be +! the same size as on the 0 node. +! + IF (MyRank.ne.0) THEN + deallocate (grid1_add_map1, grid2_add_map1, wts_map1) + allocate ( grid1_add_map1(num_links_map1), + & grid2_add_map1(num_links_map1), + & wts_map1(num_wts,num_links_map1)) + END IF +!just save the valid parts of these + IF (MyRank.eq.0) THEN + allocate (Asendi(num_links_map1)) +! + DO i=1,num_links_map1 + Asendi(i)=grid1_add_map1(i) + END DO + deallocate (grid1_add_map1) + allocate ( grid1_add_map1(num_links_map1) ) + DO i=1,num_links_map1 + grid1_add_map1(i)=Asendi(i) + END DO +! + DO i=1,num_links_map1 + Asendi(i)=grid2_add_map1(i) + END DO + deallocate (grid2_add_map1) + allocate ( grid2_add_map1(num_links_map1) ) + DO i=1,num_links_map1 + grid2_add_map1(i)=Asendi(i) + END DO + deallocate (Asendi) +! + allocate (Arecvw2d(num_wts,num_links_map1)) !wts_map1 + DO i=1,num_links_map1 + DO j=1,num_wts + Arecvw2d(j,i)=wts_map1(j,i) + END DO + END DO + deallocate (wts_map1) + allocate ( wts_map1(num_wts,num_links_map1) ) + DO i=1,num_links_map1 + DO j=1,num_wts + wts_map1(j,i)=Arecvw2d(j,i) + END DO + END DO + deallocate (Arecvw2d) + END IF +! +! send grid1_add_map1 +! + allocate (Asendi(num_links_map1)) + Asendi=0 + IF (MyRank.eq.0) THEN + DO i=1,num_links_map1 + Asendi(i)=grid1_add_map1(i) + END DO + END IF + call mpi_barrier(MyComm, MyError) + + call mpi_bcast(Asendi, num_links_map1, MPI_INT, & + & 0, MyComm, MyError) + IF (MyRank.ne.0) THEN + grid1_add_map1(1:num_links_map1)=Asendi(1:num_links_map1) + END IF +! +! send grid2_add_map1 +! + Asendi=0 + IF (MyRank.eq.0) THEN + DO i=1,num_links_map1 + Asendi(i)=grid2_add_map1(i) + END DO + END IF + call mpi_bcast(Asendi, num_links_map1, MPI_INT, & + & 0, MyComm, MyError) + IF (MyRank.ne.0) THEN +! grid2_add_map1=0 + grid2_add_map1(1:num_links_map1)=Asendi(1:num_links_map1) + END IF + deallocate (Asendi) + call mpi_barrier(MyComm, MyError) +! +! send wts_map1 +! + allocate (Asend(num_links_map1*num_wts)) + Asend=zero +! + ij=0 + IF (MyRank.eq.0) THEN + DO i=1,num_links_map1 + DO j=1,num_wts + ij=ij+1 + Asend(ij)=wts_map1(j,i) + END DO + END DO + END IF + ij=num_links_map1*num_wts + call mpi_bcast(Asend, ij, MPI_DOUBLE, & + & 0, MyComm, MyError) + IF (MyRank.ne.0) THEN + wts_map1=zero + ij=0 + DO i=1,num_links_map1 + DO j=1,num_wts + ij=ij+1 + wts_map1(j,i)=Asend(ij) + END DO + END DO + END IF + deallocate (Asend) +! +! send link_add1 +! + allocate (Asendi(grid1_size*2)) + Asendi=0 + IF (MyRank.eq.0) THEN + ij=0 + DO i=1,grid1_size + DO j=1,2 + ij=ij+1 + Asendi(ij)=link_add1(j,i) + END DO + END DO + END IF + call mpi_bcast(Asendi, grid1_size*2, MPI_INT, & + & 0, MyComm, MyError) + IF (MyRank.ne.0) THEN + link_add1=0 + ij=0 + DO i=1,grid1_size + DO j=1,2 + ij=ij+1 + link_add1(j,i)=Asendi(ij) + END DO + END DO + END IF + deallocate (Asendi) +! +! send link_add2 +! + allocate (Asendi(grid2_size*2)) + Asendi=0 + IF (MyRank.eq.0) THEN + ij=0 + DO i=1,grid2_size + DO j=1,2 + ij=ij+1 + Asendi(ij)=link_add2(j,i) + END DO + END DO + END IF + call mpi_bcast(Asendi, grid2_size*2, MPI_INT, & + & 0, MyComm, MyError) + IF (MyRank.ne.0) THEN + link_add2=0 + ij=0 + DO i=1,grid2_size + DO j=1,2 + ij=ij+1 + link_add2(j,i)=Asendi(ij) + END DO + END DO + END IF + deallocate (Asendi) +! + deallocate(Numlinks) +! CALL mpi_comm_rank (MyComm, MyRank, MyError) +!#endif + + !----------------------------------------------------------------------- ! ! correct for situations where N/S pole not explicitly included in From 566e27584802e0df6d18a3310e513ea2c22cdcd7 Mon Sep 17 00:00:00 2001 From: jcwarner-USGS Date: Fri, 19 Jul 2024 15:29:49 -0400 Subject: [PATCH 2/9] change resize in scrip conserv --- model/src/SCRIP/scrip_remap_conservative.f | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/model/src/SCRIP/scrip_remap_conservative.f b/model/src/SCRIP/scrip_remap_conservative.f index ede23706e..16f93e132 100644 --- a/model/src/SCRIP/scrip_remap_conservative.f +++ b/model/src/SCRIP/scrip_remap_conservative.f @@ -772,8 +772,7 @@ subroutine remap_conserv(l_master, l_test) if (got_weight.eq.0) then num_links_map1 = num_links_map1 + 1 if (num_links_map1 > max_links_map1) & - & call resize_remap_vars(1,max_links_map1-num_links_map1) -! & call resize_remap_vars(1,resize_increment) + & call resize_remap_vars(1,resize_increment) grid1_add_map1(num_links_map1) = add1 grid2_add_map1(num_links_map1) = add2 wts_map1 (:,num_links_map1) = Arecvw2d(1:num_wts,nlink) From 423816ffda79aace23bf651116899ffd4ade2156 Mon Sep 17 00:00:00 2001 From: jcwarner-USGS Date: Tue, 10 Sep 2024 15:42:39 -0400 Subject: [PATCH 3/9] update scrip_remap_conservative.F with SCRIPMPI, switches.json, and src_list.cmake --- model/src/SCRIP/scrip_remap_conservative.f | 321 +++++++++------------ model/src/cmake/src_list.cmake | 2 +- model/src/cmake/switches.json | 10 + 3 files changed, 144 insertions(+), 189 deletions(-) mode change 100644 => 100755 model/src/SCRIP/scrip_remap_conservative.f diff --git a/model/src/SCRIP/scrip_remap_conservative.f b/model/src/SCRIP/scrip_remap_conservative.f old mode 100644 new mode 100755 index 16f93e132..96c91d40a --- a/model/src/SCRIP/scrip_remap_conservative.f +++ b/model/src/SCRIP/scrip_remap_conservative.f @@ -252,8 +252,11 @@ subroutine remap_conserv(l_master, l_test) ! !----------------------------------------------------------------------- +#ifdef W3_SCRIPMPI USE W3ADATMD, ONLY: MPI_COMM_WAVE - + USE W3ODATMD, ONLY: IAPROC, NTPROC + INCLUDE "mpif.h" +#endif logical(SCRIP_Logical), intent(in) :: l_master ! Am I the master ! processor (do I/O)? logical(SCRIP_Logical), intent(in) :: l_test ! Whether to @@ -264,11 +267,9 @@ subroutine remap_conserv(l_master, l_test) ! local variables ! !----------------------------------------------------------------------- -!#ifdef W3_SCRIP_JCW - include 'mpif.h' - integer (SCRIP_i4) :: MyStr, MyEnd, MyComm - integer (SCRIP_i4) :: MyError, MyRank, Nprocs, rank - integer (SCRIP_i4) :: ratio +#ifdef W3_SCRIPMPI + integer (SCRIP_i4) :: grid1_str, grid1_end, grid2_str, grid2_end + integer (SCRIP_i4) :: IERR_MPI, IPROC, ratio integer (SCRIP_i4) :: j, ij, add1, add2, got_weight integer (SCRIP_i4) :: nlink, min_link, max_link integer (SCRIP_i4), dimension(MPI_STATUS_SIZE) :: status @@ -276,12 +277,11 @@ subroutine remap_conserv(l_master, l_test) integer (SCRIP_i4), dimension(:), allocatable :: Asendi integer (SCRIP_i4), dimension(:), allocatable :: Arecv1 integer (SCRIP_i4), dimension(:), allocatable :: Arecv2 -!#endif +#endif integer (SCRIP_i4), parameter :: & phi_or_theta = 2 ! integrate w.r.t. phi (1) or theta (2) - integer (SCRIP_i4) :: & i, inext, ! & n, nwgt, @@ -316,12 +316,12 @@ subroutine remap_conserv(l_master, l_test) ! and true area & ref_area ! Area of cell as computed by direct ! integration around its boundaries -!#ifdef W3_SCRIP_JCW +#ifdef W3_SCRIPMPI real (SCRIP_r8), dimension(:), allocatable :: Asend real (SCRIP_r8), dimension(:), allocatable :: Arecvw - real (SCRIP_r8), dimension(:), allocatable :: Arecv + real (SCRIP_r8), dimension(:), allocatable :: Arecv real (SCRIP_r8), dimension(:,:), allocatable :: Arecvw2d -!#endif +#endif ! call OMP_SET_DYNAMIC(.FALSE.) @@ -359,27 +359,28 @@ subroutine remap_conserv(l_master, l_test) C$OMP DO SCHEDULE(DYNAMIC) -!#ifdef W3_SCRIP_JCW - MyComm=MPI_COMM_WAVE - CALL mpi_comm_rank (MyComm, MyRank, MyError) - CALL mpi_comm_size (MyComm, Nprocs, MyError) +#ifdef W3_SCRIPMPI ! ! To do this in mpi, we will just break up the sweep loops into chunks. Then ! gather all of the data at end of each loop so that each proc has a full set of ! data. First we want to determine start and end chunks for this processor. ! - IF (Nprocs.eq.1) THEN - MyStr=1 - MyEnd=grid1_size +! Revert back to 0 based processor number. + IPROC=IAPROC-1 + IF (NTPROC.eq.1) THEN + grid1_str=1 + grid1_end=grid1_size ELSE - ratio=INT(grid1_size/Nprocs) - MyStr=(MyRank*ratio)+1 - MyEnd=MyStr+ratio-1 - IF (MyRank+1.eq.Nprocs) MyEnd=grid1_size + ratio=INT(grid1_size/NTPROC) + grid1_str=(IPROC*ratio)+1 + grid1_end=grid1_str+ratio-1 + IF (IPROC+1.eq.NTPROC) grid1_end=grid1_size END IF - -!jcw do grid1_add = 1,grid1_size - do grid1_add = MyStr,MyEnd +#else + grid1_str=1 + grid1_end=grid1_size +#endif + do grid1_add = grid1_str,grid1_end if (mod(grid1_add,progint) .eq. 0 .and. is_master) then print *, grid1_add,' of ',grid1_size,' cells processed ...' @@ -394,12 +395,12 @@ subroutine remap_conserv(l_master, l_test) C$OMP END PARALLEL -!#ifdef W3_SCRIP_JCW +#ifdef W3_SCRIPMPI ! -! Here we need to gather all the data to each proc so they know the -! full data set. +! Here we need to gather all the data processed and +! send to each proc so they know the full data set. ! -! first_call +! grid1 integrate ! allocate (Asend(grid1_size)) allocate (Arecv(grid1_size)) @@ -411,11 +412,11 @@ subroutine remap_conserv(l_master, l_test) Arecv(grid1_add)=zero END DO ! fill the send for this tile. - DO grid1_add=MyStr,MyEnd + DO grid1_add=grid1_str,grid1_end Asend(grid1_add)=grid1_frac(grid1_add) END DO - call mpi_allreduce(Asend, Arecv, grid1_size, MPI_DOUBLE, & - & MPI_SUM, MyComm, MyError) + call mpi_allreduce(Asend, Arecv, grid1_size, MPI_DOUBLE, & + & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) ! fill the working array as a sum from all nodes. DO grid1_add=1,grid1_size grid1_frac(grid1_add)=Arecv(grid1_add) @@ -428,11 +429,11 @@ subroutine remap_conserv(l_master, l_test) Arecv(grid1_add)=zero END DO ! fill the send for this tile. - DO grid1_add=MyStr,MyEnd + DO grid1_add=grid1_str,grid1_end Asend(grid1_add)=grid1_area(grid1_add) END DO - call mpi_allreduce(Asend, Arecv, grid1_size, MPI_DOUBLE, & - & MPI_SUM, MyComm, MyError) + call mpi_allreduce(Asend, Arecv, grid1_size, MPI_DOUBLE, & + & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) ! fill the working array as a sum from all nodes. DO grid1_add=1,grid1_size grid1_area(grid1_add)=Arecv(grid1_add) @@ -445,11 +446,11 @@ subroutine remap_conserv(l_master, l_test) Arecv(grid1_add)=zero END DO ! fill the send for this tile. - DO grid1_add=MyStr,MyEnd + DO grid1_add=grid1_str,grid1_end Asend(grid1_add)=grid1_centroid_lat(grid1_add) END DO - call mpi_allreduce(Asend, Arecv, grid1_size, MPI_DOUBLE, & - & MPI_SUM, MyComm, MyError) + call mpi_allreduce(Asend, Arecv, grid1_size, MPI_DOUBLE, & + & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) ! fill the working array as a sum from all nodes. DO grid1_add=1,grid1_size grid1_centroid_lat(grid1_add)=Arecv(grid1_add) @@ -462,11 +463,11 @@ subroutine remap_conserv(l_master, l_test) Arecv(grid1_add)=zero END DO ! fill the send for this tile. - DO grid1_add=MyStr,MyEnd + DO grid1_add=grid1_str,grid1_end Asend(grid1_add)=grid1_centroid_lon(grid1_add) END DO - call mpi_allreduce(Asend, Arecv, grid1_size, MPI_DOUBLE, & - & MPI_SUM, MyComm, MyError) + call mpi_allreduce(Asend, Arecv, grid1_size, MPI_DOUBLE, & + & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) ! fill the working array as a sum from all nodes. DO grid1_add=1,grid1_size grid1_centroid_lon(grid1_add)=Arecv(grid1_add) @@ -485,14 +486,14 @@ subroutine remap_conserv(l_master, l_test) DO grid2_add=1,grid2_size Asend(grid2_add)=grid2_frac(grid2_add) END DO - call mpi_allreduce(Asend, Arecv, grid2_size, MPI_DOUBLE, & - & MPI_SUM, MyComm, MyError) + call mpi_allreduce(Asend, Arecv, grid2_size, MPI_DOUBLE, & + & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) ! fill the working array as a sum from all nodes. DO grid2_add=1,grid2_size grid2_frac(grid2_add)=Arecv(grid2_add) END DO deallocate(Asend, Arecv) -!#endif +#endif !----------------------------------------------------------------------- ! @@ -523,24 +524,26 @@ subroutine remap_conserv(l_master, l_test) C$OMP DO SCHEDULE(DYNAMIC) -!#ifdef W3_SCRIP_JCW +#ifdef W3_SCRIPMPI ! ! To do this in mpi, we will just break up the sweep loops into chunks. Then ! gather all of the data at end of each loop so that each proc has a full set of ! data. First we want to determine start and end chunks for this processor. ! - IF (Nprocs.eq.1) THEN - MyStr=1 - MyEnd=grid2_size + IF (NTPROC.eq.1) THEN + grid2_str=1 + grid2_end=grid2_size ELSE - ratio=INT(grid2_size/Nprocs) - MyStr=(MyRank*ratio)+1 - MyEnd=MyStr+ratio-1 - IF (MyRank+1.eq.Nprocs) MyEnd=grid2_size + ratio=INT(grid2_size/NTPROC) + grid2_str=(IPROC*ratio)+1 + grid2_end=grid2_str+ratio-1 + IF (IPROC+1.eq.NTPROC) grid2_end=grid2_size END IF - -!jcw do grid2_add = 1,grid2_size - do grid2_add = MyStr,MyEnd +#else + grid2_str=1 + grid2_end=grid2_size +#endif + do grid2_add = grid2_str,grid2_end if (mod(grid2_add,progint) .eq. 0 .and. is_master) then print *, grid2_add,' of ',grid2_size,' cells processed ...' @@ -557,12 +560,12 @@ subroutine remap_conserv(l_master, l_test) call timer_stop(2) -!#ifdef W3_SCRIP_JCW +#ifdef W3_SCRIPMPI ! -! Here we need to gather all the data to each proc so they know the -! full data set. +! Here we need to gather all the data processed and +! send to each proc so they know the full data set. ! -! second_call +! grid2 integrate ! allocate (Asend(grid2_size)) allocate (Arecv(grid2_size)) @@ -574,11 +577,11 @@ subroutine remap_conserv(l_master, l_test) Arecv(grid2_add)=zero END DO ! fill the send for this tile. - DO grid2_add=MyStr,MyEnd + DO grid2_add=grid2_str,grid2_end Asend(grid2_add)=grid2_frac(grid2_add) END DO - call mpi_allreduce(Asend, Arecv, grid2_size, MPI_DOUBLE, & - & MPI_SUM, MyComm, MyError) + call mpi_allreduce(Asend, Arecv, grid2_size, MPI_DOUBLE, & + & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) ! fill the working array as a sum from all nodes. DO grid2_add=1,grid2_size grid2_frac(grid2_add)=Arecv(grid2_add) @@ -591,11 +594,11 @@ subroutine remap_conserv(l_master, l_test) Arecv(grid2_add)=zero END DO ! fill the send for this tile. - DO grid2_add=MyStr,MyEnd + DO grid2_add=grid2_str,grid2_end Asend(grid2_add)=grid2_area(grid2_add) END DO - call mpi_allreduce(Asend, Arecv, grid2_size, MPI_DOUBLE, & - & MPI_SUM, MyComm, MyError) + call mpi_allreduce(Asend, Arecv, grid2_size, MPI_DOUBLE, & + & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) ! fill the working array as a sum from all nodes. DO grid2_add=1,grid2_size grid2_area(grid2_add)=Arecv(grid2_add) @@ -608,11 +611,11 @@ subroutine remap_conserv(l_master, l_test) Arecv(grid2_add)=zero END DO ! fill the send for this tile. - DO grid2_add=MyStr,MyEnd + DO grid2_add=grid2_str,grid2_end Asend(grid2_add)=grid2_centroid_lat(grid2_add) END DO - call mpi_allreduce(Asend, Arecv, grid2_size, MPI_DOUBLE, & - & MPI_SUM, MyComm, MyError) + call mpi_allreduce(Asend, Arecv, grid2_size, MPI_DOUBLE, & + & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) ! fill the working array as a sum from all nodes. DO grid2_add=1,grid2_size grid2_centroid_lat(grid2_add)=Arecv(grid2_add) @@ -626,11 +629,11 @@ subroutine remap_conserv(l_master, l_test) Arecv(grid2_add)=zero END DO ! fill the send for this tile. - DO grid2_add=MyStr,MyEnd + DO grid2_add=grid2_str,grid2_end Asend(grid2_add)=grid2_centroid_lon(grid2_add) END DO - call mpi_allreduce(Asend, Arecv, grid2_size, MPI_DOUBLE, & - & MPI_SUM, MyComm, MyError) + call mpi_allreduce(Asend, Arecv, grid2_size, MPI_DOUBLE, & + & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) ! fill the working array as a sum from all nodes. DO grid2_add=1,grid2_size grid2_centroid_lon(grid2_add)=Arecv(grid2_add) @@ -649,50 +652,50 @@ subroutine remap_conserv(l_master, l_test) DO grid1_add=1,grid1_size Asend(grid1_add)=grid1_frac(grid1_add) END DO - call mpi_allreduce(Asend, Arecv, grid1_size, MPI_DOUBLE, & - & MPI_SUM, MyComm, MyError) + call mpi_allreduce(Asend, Arecv, grid1_size, MPI_DOUBLE, & + & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) ! fill the working array as a sum from all nodes. DO grid1_add=1,grid1_size grid1_frac(grid1_add)=Arecv(grid1_add) END DO deallocate(Asend, Arecv) -!#endif - - - - - -!#ifdef W3_SCRIP_JCW ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Both sweeps are now done. ! Here we need to gather all the data that was computed in -! store_link_cnsrv. +! store_link_cnsrv. Then we allow the Master node to +! compute the rest after these steps. ! -! gather total number of links that were computed on each processor. +! gather total number of links that were computed on each processor. ! - allocate(Numlinks(Nprocs)) + allocate(Numlinks(NTPROC)) call mpi_gather(num_links_map1, 1, MPI_INT, Numlinks, 1, MPI_INT, & - & 0, MyComm, MyError) + & 0, MPI_COMM_WAVE, IERR_MPI) ! ! Now gather all the weights from other nodes to make one combined set. ! - IF (MyRank.ne.0) THEN + IF (IPROC.ne.0) THEN allocate (Asendi(num_links_map1)) Asendi=0 ! +! Send grid1 add map1. DO i=1,num_links_map1 Asendi(i)=grid1_add_map1(i) END DO call mpi_send(Asendi, num_links_map1, MPI_INT, 0, & - & 10, MyComm, MyError) + & 10, MPI_COMM_WAVE, IERR_MPI) ! - Asendi(1:num_links_map1)=grid2_add_map1(1:num_links_map1) +! Send grid2 add map1. + DO i=1,num_links_map1 + Asendi(i)=grid2_add_map1(i) + END DO call mpi_send(Asendi, num_links_map1, MPI_INT, 0, & - & 20, MyComm, MyError) -! + & 20, MPI_COMM_WAVE, IERR_MPI) deallocate (Asendi) +! +! Send wts map1. allocate (Asend(num_links_map1*num_wts)) Asend=0 -! ij=0 DO i=1,num_links_map1 DO j=1,num_wts @@ -701,12 +704,10 @@ subroutine remap_conserv(l_master, l_test) END DO END DO call mpi_send(Asend, num_links_map1*num_wts, MPI_DOUBLE, 0, & - & 30, MyComm, MyError) + & 30, MPI_COMM_WAVE, IERR_MPI) deallocate (Asend) ELSE ! we are on the Master - - - DO i=2,Nprocs + DO i=2,NTPROC allocate (Arecv1(Numlinks(i))) !grid1_add_map1 allocate (Arecv2(Numlinks(i))) !grid2_add_map1 allocate (Arecvw(num_wts*Numlinks(i))) !wts_map1 @@ -716,20 +717,21 @@ subroutine remap_conserv(l_master, l_test) Arecvw=zero Arecvw2d=zero ! -! Receiving grid1 area. +! Receiving grd1 add map1 (grid1 area). ! call mpi_recv(Arecv1, Numlinks(i), MPI_INT, i-1, 10, & - & MyComm, status, MyError) + & MPI_COMM_WAVE, status, IERR_MPI) ! -! Receiving grid2 area. +! Receiving grid2 add map1 (grid2 area). ! call mpi_recv(Arecv2, Numlinks(i), MPI_INT, i-1, 20, & - & MyComm, status, MyError) + & MPI_COMM_WAVE, status, IERR_MPI) ! -! Receiving weights +! Receiving weights map1 ! call mpi_recv(Arecvw, Numlinks(i)*num_wts, MPI_DOUBLE,i-1,30, & - & MyComm, status, MyError) + & MPI_COMM_WAVE, status, IERR_MPI) +! restructure wts to be (1:num_wts,numlinks) ij=0 DO nlink=1,Numlinks(i) DO j=1,num_wts @@ -741,9 +743,9 @@ subroutine remap_conserv(l_master, l_test) ! ! if the link already exists, add the weight to the current weight ! arrays -! +! This is taken from subroutine store_link_cnsrv. !----------------------------------------------------------------------- - do nlink=1,Numlinks(i) + DO nlink=1,Numlinks(i) add1=Arecv1(nlink) add2=Arecv2(nlink) got_weight=0 @@ -787,39 +789,40 @@ subroutine remap_conserv(l_master, l_test) deallocate (Arecv1, Arecv2, Arecvw, Arecvw2d) END DO END IF - ! -! Now distribute: num_links_map1, , max_links_map1 -! grid1_add_map1, grid2_add_map1, wts_map1, -! link_add1, link_add2 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! Now distribute: num_links_map1, grid1_add_map1, grid2_add_map1, +! wts_map1, link_add1, link_add2, max_links_map1 ! ! send num_links_map1 ! call mpi_bcast(num_links_map1, 1, MPI_INT, & - & 0, MyComm, MyError) + & 0, MPI_COMM_WAVE, IERR_MPI) ! force this max_links_map1=num_links_map1 - call mpi_barrier(MyComm, MyError) ! ! here we do what is in resize_remap_vars and just make the ! sizes of grid1_add_map1, grid2_add_map1, and wts_map1 to be ! the same size as on the 0 node. ! - IF (MyRank.ne.0) THEN + IF (IPROC.ne.0) THEN deallocate (grid1_add_map1, grid2_add_map1, wts_map1) - allocate ( grid1_add_map1(num_links_map1), - & grid2_add_map1(num_links_map1), + allocate ( grid1_add_map1(num_links_map1), & + & grid2_add_map1(num_links_map1), & & wts_map1(num_wts,num_links_map1)) END IF -!just save the valid parts of these - IF (MyRank.eq.0) THEN + IF (IPROC.eq.0) THEN +! +! Only save the valid parts of grid1_add_map1, grid2_add_map1, wts_map1 +! allocate (Asendi(num_links_map1)) ! DO i=1,num_links_map1 Asendi(i)=grid1_add_map1(i) END DO deallocate (grid1_add_map1) - allocate ( grid1_add_map1(num_links_map1) ) + allocate ( grid1_add_map1(num_links_map1) ) DO i=1,num_links_map1 grid1_add_map1(i)=Asendi(i) END DO @@ -854,35 +857,35 @@ subroutine remap_conserv(l_master, l_test) ! allocate (Asendi(num_links_map1)) Asendi=0 - IF (MyRank.eq.0) THEN + IF (IPROC.eq.0) THEN DO i=1,num_links_map1 Asendi(i)=grid1_add_map1(i) END DO END IF - call mpi_barrier(MyComm, MyError) - call mpi_bcast(Asendi, num_links_map1, MPI_INT, & - & 0, MyComm, MyError) - IF (MyRank.ne.0) THEN - grid1_add_map1(1:num_links_map1)=Asendi(1:num_links_map1) + & 0, MPI_COMM_WAVE, IERR_MPI) + IF (IPROC.ne.0) THEN + DO i=1,num_links_map1 + grid1_add_map1(i)=Asendi(i) + END DO END IF ! ! send grid2_add_map1 ! Asendi=0 - IF (MyRank.eq.0) THEN + IF (IPROC.eq.0) THEN DO i=1,num_links_map1 Asendi(i)=grid2_add_map1(i) END DO END IF call mpi_bcast(Asendi, num_links_map1, MPI_INT, & - & 0, MyComm, MyError) - IF (MyRank.ne.0) THEN -! grid2_add_map1=0 - grid2_add_map1(1:num_links_map1)=Asendi(1:num_links_map1) + & 0, MPI_COMM_WAVE, IERR_MPI) + IF (IPROC.ne.0) THEN + DO i=1,num_links_map1 + grid2_add_map1(i)=Asendi(i) + END DO END IF deallocate (Asendi) - call mpi_barrier(MyComm, MyError) ! ! send wts_map1 ! @@ -890,7 +893,7 @@ subroutine remap_conserv(l_master, l_test) Asend=zero ! ij=0 - IF (MyRank.eq.0) THEN + IF (IPROC.eq.0) THEN DO i=1,num_links_map1 DO j=1,num_wts ij=ij+1 @@ -900,8 +903,8 @@ subroutine remap_conserv(l_master, l_test) END IF ij=num_links_map1*num_wts call mpi_bcast(Asend, ij, MPI_DOUBLE, & - & 0, MyComm, MyError) - IF (MyRank.ne.0) THEN + & 0, MPI_COMM_WAVE, IERR_MPI) + IF (IPROC.ne.0) THEN wts_map1=zero ij=0 DO i=1,num_links_map1 @@ -912,66 +915,8 @@ subroutine remap_conserv(l_master, l_test) END DO END IF deallocate (Asend) -! -! send link_add1 -! - allocate (Asendi(grid1_size*2)) - Asendi=0 - IF (MyRank.eq.0) THEN - ij=0 - DO i=1,grid1_size - DO j=1,2 - ij=ij+1 - Asendi(ij)=link_add1(j,i) - END DO - END DO - END IF - call mpi_bcast(Asendi, grid1_size*2, MPI_INT, & - & 0, MyComm, MyError) - IF (MyRank.ne.0) THEN - link_add1=0 - ij=0 - DO i=1,grid1_size - DO j=1,2 - ij=ij+1 - link_add1(j,i)=Asendi(ij) - END DO - END DO - END IF - deallocate (Asendi) -! -! send link_add2 -! - allocate (Asendi(grid2_size*2)) - Asendi=0 - IF (MyRank.eq.0) THEN - ij=0 - DO i=1,grid2_size - DO j=1,2 - ij=ij+1 - Asendi(ij)=link_add2(j,i) - END DO - END DO - END IF - call mpi_bcast(Asendi, grid2_size*2, MPI_INT, & - & 0, MyComm, MyError) - IF (MyRank.ne.0) THEN - link_add2=0 - ij=0 - DO i=1,grid2_size - DO j=1,2 - ij=ij+1 - link_add2(j,i)=Asendi(ij) - END DO - END DO - END IF - deallocate (Asendi) -! deallocate(Numlinks) -! CALL mpi_comm_rank (MyComm, MyRank, MyError) -!#endif - - +#endif !----------------------------------------------------------------------- ! ! correct for situations where N/S pole not explicitly included in diff --git a/model/src/cmake/src_list.cmake b/model/src/cmake/src_list.cmake index d745be388..317dd5016 100644 --- a/model/src/cmake/src_list.cmake +++ b/model/src/cmake/src_list.cmake @@ -81,7 +81,7 @@ set(scrip_src ${CMAKE_CURRENT_SOURCE_DIR}/SCRIP/scrip_interface.F90 ${CMAKE_CURRENT_SOURCE_DIR}/SCRIP/scrip_iounitsmod.f90 ${CMAKE_CURRENT_SOURCE_DIR}/SCRIP/scrip_kindsmod.f90 - ${CMAKE_CURRENT_SOURCE_DIR}/SCRIP/scrip_remap_conservative.f + ${CMAKE_CURRENT_SOURCE_DIR}/SCRIP/scrip_remap_conservative.F ${CMAKE_CURRENT_SOURCE_DIR}/SCRIP/scrip_remap_vars.f ${CMAKE_CURRENT_SOURCE_DIR}/SCRIP/scrip_timers.f ) diff --git a/model/src/cmake/switches.json b/model/src/cmake/switches.json index a7b9bc94f..999f46e5c 100644 --- a/model/src/cmake/switches.json +++ b/model/src/cmake/switches.json @@ -43,6 +43,16 @@ } ] }, + { + "name": "scripmpi", + "num_switches": "upto2", + "description": "", + "valid-options": [ + { + "name": "SCRIPMPI" + } + ] + }, { "name": "shared", "num_switches": "one", From fbac1cc21cd38050c91a5a6e6de63633bd3f7a80 Mon Sep 17 00:00:00 2001 From: jcwarner-USGS Date: Tue, 10 Sep 2024 15:45:15 -0400 Subject: [PATCH 4/9] update scrip_remap_conservative.F with SCRIPMPI, switches.json, and src_list.cmake --- model/src/SCRIP/scrip_remap_conservative.f | 6853 -------------------- 1 file changed, 6853 deletions(-) delete mode 100755 model/src/SCRIP/scrip_remap_conservative.f diff --git a/model/src/SCRIP/scrip_remap_conservative.f b/model/src/SCRIP/scrip_remap_conservative.f deleted file mode 100755 index 96c91d40a..000000000 --- a/model/src/SCRIP/scrip_remap_conservative.f +++ /dev/null @@ -1,6853 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! this module contains necessary routines for computing addresses -! and weights for a conservative interpolation between any two -! grids on a sphere. the weights are computed by performing line -! integrals around all overlap regions of the two grids. see -! Dukowicz and Kodis, SIAM J. Sci. Stat. Comput. 8, 305 (1987) and -! Jones, P.W. Monthly Weather Review (submitted). -! -!----------------------------------------------------------------------- -! -! CVS:$Id: remap_conserv.f,v 1.10 2001/08/21 21:05:13 pwjones Exp $ -! -! Copyright (c) 1997, 1998 the Regents of the University of -! California. -! -! This software and ancillary information (herein called software) -! called SCRIP is made available under the terms described here. -! The software has been approved for release with associated -! LA-CC Number 98-45. -! -! Unless otherwise indicated, this software has been authored -! by an employee or employees of the University of California, -! operator of the Los Alamos National Laboratory under Contract -! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. -! Government has rights to use, reproduce, and distribute this -! software. The public may copy and use this software without -! charge, provided that this Notice and any statement of authorship -! are reproduced on all copies. Neither the Government nor the -! University makes any warranty, express or implied, or assumes -! any liability or responsibility for the use of this software. -! -! If software is modified to produce derivative works, such modified -! software should be clearly marked, so as not to confuse it with -! the version available from Los Alamos National Laboratory. -! -! This code has been modified from the version available from -! Los Alamos National Laboratory, for the purpose of running it -! within WW3. Primary modifications: -! - renamed many variables to be unique across the code -! - "save" variables moved from subroutine to module so that -! we can "clear" them later. -! - print statements added. -! - phi_or_theta = 2 instead of phi_or_theta = 1 (important!) -! -!*********************************************************************** -! Modifications introduced by M. Dutour (MD) for -! running with WAVEWATCH III ... see below -! -! -! BE CAREFUL ABOUT EXPLICIT INITIALIZATION OF VARIABLES IN -! MULTI-THREADED VERSION OF THE CODE - INLINE INITIALIZATION OF -! A VARIABLE IN FORTRAN 90/95 MAKES THE VARIABLE IMPLICITLY STATIC. -! OPENMP FORCES _ALL_ FORTRAN IMPLEMENTATIONS TO MAKE THE VARIABLE -! STATIC (OR OF THE TYPE SAVE) IF IT IS INITIALIZED IN THE -! DECLARATION LINE -! -! - - module scrip_remap_conservative - -!----------------------------------------------------------------------- - - use SCRIP_KindsMod ! defines common data types - use SCRIP_constants ! defines common constants - use scrip_timers ! module for timing - use scrip_grids ! module containing grid information - use scrip_remap_vars ! module containing remap information - use omp_lib - - implicit none - - integer (SCRIP_i4) :: nthreads=2 ! Number of parallel threads - -!............variables that needed to be moved from "local level" to -!............ "module level" in order that we can clear them later. -!............These are all local variables that had the "save" attribute -!............in the standard version of SCRIP - - integer (SCRIP_i4), save :: - & avoid_pole_count = 0 ! count attempts to avoid pole - - real (SCRIP_r8), save :: - & avoid_pole_offset = tiny ! endpoint offset to avoid pole - - integer (SCRIP_i4), dimension(:,:), allocatable, save :: - & link_add1, ! min,max link add to restrict search - & link_add2 ! min,max link add to restrict search - - logical (SCRIP_logical), save :: - & first_call_store_link_cnsrv = .true. - - logical (SCRIP_logical), save :: - & first_call_locate_segstart= .true. - - integer (SCRIP_i4), save :: - & last_cell_locate_segstart=0, ! save the search parameters - & last_cell_grid_num_locate_segstart=0, ! if unchanged, reuse - ! search lists - & last_srch_grid_num_locate_segstart=0 - - integer (SCRIP_i4), save :: - & num_srch_cells_locate_segstart=0, - & srch_corners_locate_segstart ! number of corners for - ! each cell - - integer (SCRIP_i4), dimension(:), allocatable, save :: - & srch_add_locate_segstart ! global address of cells - ! in srch arrays - - real (SCRIP_r8), dimension(:,:), allocatable, save :: - & srch_corner_lat_locate_segstart, ! lat of each corner of - ! srch cells - & srch_corner_lon_locate_segstart ! lon of each corner of - ! srch cells - - real(SCRIP_r8), dimension(:), allocatable, save :: - & srch_center_lat_locate_segstart,! lat of center of srch cells - & srch_center_lon_locate_segstart ! lon of center of srch cells - - logical (SCRIP_logical), save :: - & first_call_locate_point= .true. - - integer (SCRIP_i4), save :: - & last_cell_locate_point=0, ! save the search parameters - & last_cell_grid_num_locate_point=0, ! if unchanged, reuse - ! search lists - & last_srch_grid_num_locate_point=0 - - integer (SCRIP_i4), save :: - & num_srch_cell_locate_points=0, - & srch_corners_locate_point ! number of corners for each cell - - integer (SCRIP_i4), dimension(:), allocatable, save :: - & srch_add_locate_point ! global address of cells in - ! srch arrays - - real (SCRIP_r8), dimension(:,:), allocatable, save :: - & srch_corner_lat_locate_point, ! lat of each corner of srch - ! cells - & srch_corner_lon_locate_point ! lon of each corner of srch - ! cells - - real (SCRIP_r8), dimension(:), allocatable, save :: - & srch_center_lat_locate_point, ! lat of center of srch cells - & srch_center_lon_locate_point ! lon of center of srch cells - - integer (SCRIP_i4), save :: - & num_srch_cells_loc_get_srch_cells, ! Number of srch cells - ! found - & srch_corners_loc_get_srch_cells ! Number of corners for - ! search cells - - integer (SCRIP_i4), dimension(:), allocatable, save :: - & srch_add_loc_get_srch_cells ! Global addresses of - ! search cells - - real (SCRIP_r8), dimension(:,:), allocatable, save :: - & srch_corner_lat_loc_get_srch_cells, - & srch_corner_lon_loc_get_srch_cells - - real (SCRIP_r8), dimension(:), allocatable, save :: - & srch_center_lat_loc_get_srch_cells, - & srch_center_lon_loc_get_srch_cells - - integer (SCRIP_i4), save :: - & last_cell_add_get_srch_cells, - & last_cell_grid_num_get_srch_cells, - & last_srch_grid_num_get_srch_cells - - logical (SCRIP_logical), save :: - & first_call_get_srch_cells=.true. - - logical (SCRIP_logical), save :: - & first_call_find_adj_cell=.true. - - logical (SCRIP_logical), private :: is_master - ! module's equivalent of "l_master" - - integer (SCRIP_i4), save :: - & last_cell_find_adj_cell, - & last_cell_grid_num_find_adj_cell, - & num_srch_cells_find_adj_cell, - & srch_corners_find_adj_cell - - integer (SCRIP_i4), dimension(:), allocatable, save :: - & srch_add_find_adj_cell - real (SCRIP_r8), dimension(:,:), allocatable, save :: - & srch_corner_lat_find_adj_cell, srch_corner_lon_find_adj_cell - - real (SCRIP_r8), dimension(:), allocatable, save :: - & srch_center_lat_find_adj_cell, srch_center_lon_find_adj_cell - -C$OMP THREADPRIVATE(last_cell_grid_num_get_srch_cells, -C$OMP& last_srch_grid_num_get_srch_cells, -C$OMP& first_call_get_srch_cells, -C$OMP& last_cell_add_get_srch_cells, -C$OMP& num_srch_cells_loc_get_srch_cells, -C$OMP& srch_corners_loc_get_srch_cells, -C$OMP& srch_add_loc_get_srch_cells, -C$OMP& srch_corner_lat_loc_get_srch_cells, -C$OMP& srch_corner_lon_loc_get_srch_cells, -C$OMP& srch_center_lat_loc_get_srch_cells, -C$OMP& srch_center_lon_loc_get_srch_cells) - -C$OMP THREADPRIVATE(first_call_locate_segstart, -C$OMP& last_cell_locate_segstart, -C$OMP& last_cell_grid_num_locate_segstart, -C$OMP& last_srch_grid_num_locate_segstart, -C$OMP& num_srch_cells_locate_segstart, -C$OMP& srch_corners_locate_segstart, -C$OMP& srch_add_locate_segstart, -C$OMP& srch_corner_lat_locate_segstart, -C$OMP& srch_corner_lon_locate_segstart, -C$OMP& srch_center_lat_locate_segstart, -C$OMP& srch_center_lon_locate_segstart) - -C$OMP THREADPRIVATE(first_call_locate_point, -C$OMP& last_cell_locate_point, -C$OMP& last_cell_grid_num_locate_point, -C$OMP& last_srch_grid_num_locate_point, -C$OMP& num_srch_cell_locate_points, -C$OMP& srch_add_locate_point,srch_corner_lat_locate_point, -C$OMP& srch_corner_lon_locate_point, -C$OMP& srch_center_lat_locate_point, -C$OMP& srch_center_lon_locate_point) - -C$OMP THREADPRIVATE(first_call_find_adj_cell, -C$OMP& last_cell_find_adj_cell, -C$OMP& last_cell_grid_num_find_adj_cell, -C$OMP& num_srch_cells_find_adj_cell, -C$OMP& srch_corners_find_adj_cell, -C$OMP& srch_add_find_adj_cell, -C$OMP& srch_corner_lat_find_adj_cell, -C$OMP& srch_corner_lon_find_adj_cell, -C$OMP& srch_center_lat_find_adj_cell, -C$OMP& srch_center_lon_find_adj_cell) - -!*********************************************************************** - - contains - -!*********************************************************************** - - subroutine remap_conserv(l_master, l_test) - -!----------------------------------------------------------------------- -! -! this routine traces the perimeters of every grid cell on each -! grid checking for intersections with the other grid and computing -! line integrals for each subsegment. -! -!----------------------------------------------------------------------- - -#ifdef W3_SCRIPMPI - USE W3ADATMD, ONLY: MPI_COMM_WAVE - USE W3ODATMD, ONLY: IAPROC, NTPROC - INCLUDE "mpif.h" -#endif - logical(SCRIP_Logical), intent(in) :: l_master ! Am I the master - ! processor (do I/O)? - logical(SCRIP_Logical), intent(in) :: l_test ! Whether to - !include test output - -!----------------------------------------------------------------------- -! -! local variables -! -!----------------------------------------------------------------------- -#ifdef W3_SCRIPMPI - integer (SCRIP_i4) :: grid1_str, grid1_end, grid2_str, grid2_end - integer (SCRIP_i4) :: IERR_MPI, IPROC, ratio - integer (SCRIP_i4) :: j, ij, add1, add2, got_weight - integer (SCRIP_i4) :: nlink, min_link, max_link - integer (SCRIP_i4), dimension(MPI_STATUS_SIZE) :: status - integer (SCRIP_i4), dimension(:), allocatable :: Numlinks - integer (SCRIP_i4), dimension(:), allocatable :: Asendi - integer (SCRIP_i4), dimension(:), allocatable :: Arecv1 - integer (SCRIP_i4), dimension(:), allocatable :: Arecv2 -#endif - - integer (SCRIP_i4), parameter :: - & phi_or_theta = 2 ! integrate w.r.t. phi (1) or theta (2) - - integer (SCRIP_i4) :: - & i, inext, ! - & n, nwgt, - & grid1_add, ! Current linear address for grid1 cell - & grid2_add, ! Current linear address for grid2 cell - & grid_num, ! Index (1,2) of grid that we are - ! processing - & opp_grid_num, ! Index of opposite grid (2,1) - & maxrd_cell, ! cell with the max. relative difference - ! in area - & progint, ! Intervals at which progress is to be - ! printed - & icount ! for counting - - real (SCRIP_r8) :: - & norm_factor ! factor for normalizing wts - - real (SCRIP_r8), dimension(6) :: - & weights ! Weights array - - real (SCRIP_r8) :: - & beglat, beglon, - & endlat, endlon, - & ave_reldiff, ! Average rel. diff. in areas - & max_reldiff, ! Maximum rel. diff in areas - & maxrd_area, ! Computed area for cell with max rel - ! diff - & maxrd_true ! True area for cell with max rel diff - - real (SCRIP_r8), dimension(:), allocatable :: - & reldiff, ! Relative difference in computed - ! and true area - & ref_area ! Area of cell as computed by direct - ! integration around its boundaries -#ifdef W3_SCRIPMPI - real (SCRIP_r8), dimension(:), allocatable :: Asend - real (SCRIP_r8), dimension(:), allocatable :: Arecvw - real (SCRIP_r8), dimension(:), allocatable :: Arecv - real (SCRIP_r8), dimension(:,:), allocatable :: Arecvw2d -#endif - -! call OMP_SET_DYNAMIC(.FALSE.) - -!----------------------------------------------------------------------- -! -! integrate around each cell on grid1 -! -!----------------------------------------------------------------------- - - is_master=l_master ! set module variable using subroutine input - ! argument variable. - ! Use the former subsequently. - - if(is_master)print *,'grid1 sweep' - -!NRL Progress is slow when the other grid (grid 2) is large, so we use -!NRL that. Really, it would be a better to do this with a timer... - if (grid2_size > 500000) then - progint = 1000 - elseif (grid2_size > 250000) then - progint = 2000 - elseif (grid2_size > 100000) then - progint = 5000 - else - progint = 10000 - endif - - grid_num = 1 - opp_grid_num = 2 - - call timer_start(1) - -C$OMP PARALLEL DEFAULT(SHARED) PRIVATE(grid1_add) NUM_THREADS(nthreads) - -C$OMP DO SCHEDULE(DYNAMIC) - - -#ifdef W3_SCRIPMPI -! -! To do this in mpi, we will just break up the sweep loops into chunks. Then -! gather all of the data at end of each loop so that each proc has a full set of -! data. First we want to determine start and end chunks for this processor. -! -! Revert back to 0 based processor number. - IPROC=IAPROC-1 - IF (NTPROC.eq.1) THEN - grid1_str=1 - grid1_end=grid1_size - ELSE - ratio=INT(grid1_size/NTPROC) - grid1_str=(IPROC*ratio)+1 - grid1_end=grid1_str+ratio-1 - IF (IPROC+1.eq.NTPROC) grid1_end=grid1_size - END IF -#else - grid1_str=1 - grid1_end=grid1_size -#endif - do grid1_add = grid1_str,grid1_end - - if (mod(grid1_add,progint) .eq. 0 .and. is_master) then - print *, grid1_add,' of ',grid1_size,' cells processed ...' - endif - - call cell_integrate(grid1_add, grid_num, phi_or_theta) - - end do ! do grid1_add=... - -C$OMP END DO - -C$OMP END PARALLEL - - -#ifdef W3_SCRIPMPI -! -! Here we need to gather all the data processed and -! send to each proc so they know the full data set. -! -! grid1 integrate -! - allocate (Asend(grid1_size)) - allocate (Arecv(grid1_size)) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Work on grid1_frac(grid1_size) -! zero it out. - DO grid1_add=1,grid1_size - Asend(grid1_add)=zero - Arecv(grid1_add)=zero - END DO -! fill the send for this tile. - DO grid1_add=grid1_str,grid1_end - Asend(grid1_add)=grid1_frac(grid1_add) - END DO - call mpi_allreduce(Asend, Arecv, grid1_size, MPI_DOUBLE, & - & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) -! fill the working array as a sum from all nodes. - DO grid1_add=1,grid1_size - grid1_frac(grid1_add)=Arecv(grid1_add) - END DO -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Work on grid1_area(grid1_size) -! zero it out. - DO grid1_add=1,grid1_size - Asend(grid1_add)=zero - Arecv(grid1_add)=zero - END DO -! fill the send for this tile. - DO grid1_add=grid1_str,grid1_end - Asend(grid1_add)=grid1_area(grid1_add) - END DO - call mpi_allreduce(Asend, Arecv, grid1_size, MPI_DOUBLE, & - & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) -! fill the working array as a sum from all nodes. - DO grid1_add=1,grid1_size - grid1_area(grid1_add)=Arecv(grid1_add) - END DO -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Work on grid1_centroid_lat(grid1_size) -! zero it out. - DO grid1_add=1,grid1_size - Asend(grid1_add)=zero - Arecv(grid1_add)=zero - END DO -! fill the send for this tile. - DO grid1_add=grid1_str,grid1_end - Asend(grid1_add)=grid1_centroid_lat(grid1_add) - END DO - call mpi_allreduce(Asend, Arecv, grid1_size, MPI_DOUBLE, & - & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) -! fill the working array as a sum from all nodes. - DO grid1_add=1,grid1_size - grid1_centroid_lat(grid1_add)=Arecv(grid1_add) - END DO -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Work on grid1_centroid_lon(grid1_size) -! zero it out. - DO grid1_add=1,grid1_size - Asend(grid1_add)=zero - Arecv(grid1_add)=zero - END DO -! fill the send for this tile. - DO grid1_add=grid1_str,grid1_end - Asend(grid1_add)=grid1_centroid_lon(grid1_add) - END DO - call mpi_allreduce(Asend, Arecv, grid1_size, MPI_DOUBLE, & - & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) -! fill the working array as a sum from all nodes. - DO grid1_add=1,grid1_size - grid1_centroid_lon(grid1_add)=Arecv(grid1_add) - END DO - deallocate(Asend, Arecv) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - allocate (Asend(grid2_size)) - allocate (Arecv(grid2_size)) -! Work on grid2_frac(grid2_size) -! zero it out. - DO grid2_add=1,grid2_size - Asend(grid2_add)=zero - Arecv(grid2_add)=zero - END DO -! fill the send for this tile. - DO grid2_add=1,grid2_size - Asend(grid2_add)=grid2_frac(grid2_add) - END DO - call mpi_allreduce(Asend, Arecv, grid2_size, MPI_DOUBLE, & - & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) -! fill the working array as a sum from all nodes. - DO grid2_add=1,grid2_size - grid2_frac(grid2_add)=Arecv(grid2_add) - END DO - deallocate(Asend, Arecv) -#endif - -!----------------------------------------------------------------------- -! -! integrate around each cell on grid2 -! -!----------------------------------------------------------------------- - - if(is_master)print *,'grid2 sweep ' - -!NRL Progress is slow when the other grid (grid 1) is large, so we use -!NRL that. - if (grid1_size > 500000) then - progint = 1000 - elseif (grid1_size > 250000) then - progint = 2000 - elseif (grid1_size > 100000) then - progint = 5000 - else - progint = 10000 - endif - - grid_num = 2 - opp_grid_num = 1 - - call timer_start(2) - -C$OMP PARALLEL DEFAULT(SHARED) PRIVATE(grid2_add) NUM_THREADS(nthreads) - -C$OMP DO SCHEDULE(DYNAMIC) - -#ifdef W3_SCRIPMPI -! -! To do this in mpi, we will just break up the sweep loops into chunks. Then -! gather all of the data at end of each loop so that each proc has a full set of -! data. First we want to determine start and end chunks for this processor. -! - IF (NTPROC.eq.1) THEN - grid2_str=1 - grid2_end=grid2_size - ELSE - ratio=INT(grid2_size/NTPROC) - grid2_str=(IPROC*ratio)+1 - grid2_end=grid2_str+ratio-1 - IF (IPROC+1.eq.NTPROC) grid2_end=grid2_size - END IF -#else - grid2_str=1 - grid2_end=grid2_size -#endif - do grid2_add = grid2_str,grid2_end - - if (mod(grid2_add,progint) .eq. 0 .and. is_master) then - print *, grid2_add,' of ',grid2_size,' cells processed ...' - endif - - call cell_integrate(grid2_add, grid_num, phi_or_theta) - - end do ! do grid2_add=... - -C$OMP END DO - -C$OMP END PARALLEL - - call timer_stop(2) - - -#ifdef W3_SCRIPMPI -! -! Here we need to gather all the data processed and -! send to each proc so they know the full data set. -! -! grid2 integrate -! - allocate (Asend(grid2_size)) - allocate (Arecv(grid2_size)) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Work on grid2_frac(grid2_size) -! zero it out. - DO grid2_add=1,grid2_size - Asend(grid2_add)=zero - Arecv(grid2_add)=zero - END DO -! fill the send for this tile. - DO grid2_add=grid2_str,grid2_end - Asend(grid2_add)=grid2_frac(grid2_add) - END DO - call mpi_allreduce(Asend, Arecv, grid2_size, MPI_DOUBLE, & - & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) -! fill the working array as a sum from all nodes. - DO grid2_add=1,grid2_size - grid2_frac(grid2_add)=Arecv(grid2_add) - END DO -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Work on grid2_area(grid2_size) -! zero it out. - DO grid2_add=1,grid2_size - Asend(grid2_add)=zero - Arecv(grid2_add)=zero - END DO -! fill the send for this tile. - DO grid2_add=grid2_str,grid2_end - Asend(grid2_add)=grid2_area(grid2_add) - END DO - call mpi_allreduce(Asend, Arecv, grid2_size, MPI_DOUBLE, & - & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) -! fill the working array as a sum from all nodes. - DO grid2_add=1,grid2_size - grid2_area(grid2_add)=Arecv(grid2_add) - END DO -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Work on grid2_centroid_lat(grid2_size) -! zero it out. - DO grid2_add=1,grid2_size - Asend(grid2_add)=zero - Arecv(grid2_add)=zero - END DO -! fill the send for this tile. - DO grid2_add=grid2_str,grid2_end - Asend(grid2_add)=grid2_centroid_lat(grid2_add) - END DO - call mpi_allreduce(Asend, Arecv, grid2_size, MPI_DOUBLE, & - & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) -! fill the working array as a sum from all nodes. - DO grid2_add=1,grid2_size - grid2_centroid_lat(grid2_add)=Arecv(grid2_add) - END DO -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Work on grid2_centroid_lon(grid2_size) -! zero it out. - DO grid2_add=1,grid2_size - Asend(grid2_add)=zero - Arecv(grid2_add)=zero - END DO -! fill the send for this tile. - DO grid2_add=grid2_str,grid2_end - Asend(grid2_add)=grid2_centroid_lon(grid2_add) - END DO - call mpi_allreduce(Asend, Arecv, grid2_size, MPI_DOUBLE, & - & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) -! fill the working array as a sum from all nodes. - DO grid2_add=1,grid2_size - grid2_centroid_lon(grid2_add)=Arecv(grid2_add) - END DO - deallocate(Asend, Arecv) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - allocate (Asend(grid1_size)) - allocate (Arecv(grid1_size)) -! Work on grid1_frac(grid1_size) -! zero it out. - DO grid1_add=1,grid1_size - Asend(grid1_add)=zero - Arecv(grid1_add)=zero - END DO -! fill the send for this tile. - DO grid1_add=1,grid1_size - Asend(grid1_add)=grid1_frac(grid1_add) - END DO - call mpi_allreduce(Asend, Arecv, grid1_size, MPI_DOUBLE, & - & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) -! fill the working array as a sum from all nodes. - DO grid1_add=1,grid1_size - grid1_frac(grid1_add)=Arecv(grid1_add) - END DO - deallocate(Asend, Arecv) -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Both sweeps are now done. -! Here we need to gather all the data that was computed in -! store_link_cnsrv. Then we allow the Master node to -! compute the rest after these steps. -! -! gather total number of links that were computed on each processor. -! - allocate(Numlinks(NTPROC)) - call mpi_gather(num_links_map1, 1, MPI_INT, Numlinks, 1, MPI_INT, & - & 0, MPI_COMM_WAVE, IERR_MPI) -! -! Now gather all the weights from other nodes to make one combined set. -! - IF (IPROC.ne.0) THEN - allocate (Asendi(num_links_map1)) - Asendi=0 -! -! Send grid1 add map1. - DO i=1,num_links_map1 - Asendi(i)=grid1_add_map1(i) - END DO - call mpi_send(Asendi, num_links_map1, MPI_INT, 0, & - & 10, MPI_COMM_WAVE, IERR_MPI) -! -! Send grid2 add map1. - DO i=1,num_links_map1 - Asendi(i)=grid2_add_map1(i) - END DO - call mpi_send(Asendi, num_links_map1, MPI_INT, 0, & - & 20, MPI_COMM_WAVE, IERR_MPI) - deallocate (Asendi) -! -! Send wts map1. - allocate (Asend(num_links_map1*num_wts)) - Asend=0 - ij=0 - DO i=1,num_links_map1 - DO j=1,num_wts - ij=ij+1 - Asend(ij)=wts_map1(j,i) - END DO - END DO - call mpi_send(Asend, num_links_map1*num_wts, MPI_DOUBLE, 0, & - & 30, MPI_COMM_WAVE, IERR_MPI) - deallocate (Asend) - ELSE ! we are on the Master - DO i=2,NTPROC - allocate (Arecv1(Numlinks(i))) !grid1_add_map1 - allocate (Arecv2(Numlinks(i))) !grid2_add_map1 - allocate (Arecvw(num_wts*Numlinks(i))) !wts_map1 - allocate (Arecvw2d(num_wts,Numlinks(i))) !wts_map1 - Arecv1=0 - Arecv2=0 - Arecvw=zero - Arecvw2d=zero -! -! Receiving grd1 add map1 (grid1 area). -! - call mpi_recv(Arecv1, Numlinks(i), MPI_INT, i-1, 10, & - & MPI_COMM_WAVE, status, IERR_MPI) -! -! Receiving grid2 add map1 (grid2 area). -! - call mpi_recv(Arecv2, Numlinks(i), MPI_INT, i-1, 20, & - & MPI_COMM_WAVE, status, IERR_MPI) -! -! Receiving weights map1 -! - call mpi_recv(Arecvw, Numlinks(i)*num_wts, MPI_DOUBLE,i-1,30, & - & MPI_COMM_WAVE, status, IERR_MPI) -! restructure wts to be (1:num_wts,numlinks) - ij=0 - DO nlink=1,Numlinks(i) - DO j=1,num_wts - ij=ij+1 - Arecvw2d(j,nlink)=Arecvw(ij) - END DO - END DO -!----------------------------------------------------------------------- -! -! if the link already exists, add the weight to the current weight -! arrays -! This is taken from subroutine store_link_cnsrv. -!----------------------------------------------------------------------- - DO nlink=1,Numlinks(i) - add1=Arecv1(nlink) - add2=Arecv2(nlink) - got_weight=0 -! - min_link = min(link_add1(1,add1),link_add2(1,add2)) - max_link = max(link_add1(2,add1),link_add2(2,add2)) - if (min_link == 0) then - min_link = 1 - max_link = 0 - endif - do j=min_link,max_link - if (add1 == grid1_add_map1(j)) then - if (add2 == grid2_add_map1(j)) then - wts_map1(:,j)=wts_map1(:,j)+Arecvw2d(1:num_wts,nlink) - got_weight=1 - endif - endif - end do -!----------------------------------------------------------------------- -! -! if the link does not yet exist, increment number of links and -! check to see if remap arrays need to be increased to accomodate -! the new link. then store the link. -! -!----------------------------------------------------------------------- - if (got_weight.eq.0) then - num_links_map1 = num_links_map1 + 1 - if (num_links_map1 > max_links_map1) & - & call resize_remap_vars(1,resize_increment) - grid1_add_map1(num_links_map1) = add1 - grid2_add_map1(num_links_map1) = add2 - wts_map1 (:,num_links_map1) = Arecvw2d(1:num_wts,nlink) - END IF - - if (link_add1(1,add1) == 0) link_add1(1,add1)=num_links_map1 - if (link_add2(1,add2) == 0) link_add2(1,add2)=num_links_map1 - link_add1(2,add1) = num_links_map1 - link_add2(2,add2) = num_links_map1 - - END DO - deallocate (Arecv1, Arecv2, Arecvw, Arecvw2d) - END DO - END IF -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! Now distribute: num_links_map1, grid1_add_map1, grid2_add_map1, -! wts_map1, link_add1, link_add2, max_links_map1 -! -! send num_links_map1 -! - call mpi_bcast(num_links_map1, 1, MPI_INT, & - & 0, MPI_COMM_WAVE, IERR_MPI) -! force this - max_links_map1=num_links_map1 -! -! here we do what is in resize_remap_vars and just make the -! sizes of grid1_add_map1, grid2_add_map1, and wts_map1 to be -! the same size as on the 0 node. -! - IF (IPROC.ne.0) THEN - deallocate (grid1_add_map1, grid2_add_map1, wts_map1) - allocate ( grid1_add_map1(num_links_map1), & - & grid2_add_map1(num_links_map1), & - & wts_map1(num_wts,num_links_map1)) - END IF - IF (IPROC.eq.0) THEN -! -! Only save the valid parts of grid1_add_map1, grid2_add_map1, wts_map1 -! - allocate (Asendi(num_links_map1)) -! - DO i=1,num_links_map1 - Asendi(i)=grid1_add_map1(i) - END DO - deallocate (grid1_add_map1) - allocate ( grid1_add_map1(num_links_map1) ) - DO i=1,num_links_map1 - grid1_add_map1(i)=Asendi(i) - END DO -! - DO i=1,num_links_map1 - Asendi(i)=grid2_add_map1(i) - END DO - deallocate (grid2_add_map1) - allocate ( grid2_add_map1(num_links_map1) ) - DO i=1,num_links_map1 - grid2_add_map1(i)=Asendi(i) - END DO - deallocate (Asendi) -! - allocate (Arecvw2d(num_wts,num_links_map1)) !wts_map1 - DO i=1,num_links_map1 - DO j=1,num_wts - Arecvw2d(j,i)=wts_map1(j,i) - END DO - END DO - deallocate (wts_map1) - allocate ( wts_map1(num_wts,num_links_map1) ) - DO i=1,num_links_map1 - DO j=1,num_wts - wts_map1(j,i)=Arecvw2d(j,i) - END DO - END DO - deallocate (Arecvw2d) - END IF -! -! send grid1_add_map1 -! - allocate (Asendi(num_links_map1)) - Asendi=0 - IF (IPROC.eq.0) THEN - DO i=1,num_links_map1 - Asendi(i)=grid1_add_map1(i) - END DO - END IF - call mpi_bcast(Asendi, num_links_map1, MPI_INT, & - & 0, MPI_COMM_WAVE, IERR_MPI) - IF (IPROC.ne.0) THEN - DO i=1,num_links_map1 - grid1_add_map1(i)=Asendi(i) - END DO - END IF -! -! send grid2_add_map1 -! - Asendi=0 - IF (IPROC.eq.0) THEN - DO i=1,num_links_map1 - Asendi(i)=grid2_add_map1(i) - END DO - END IF - call mpi_bcast(Asendi, num_links_map1, MPI_INT, & - & 0, MPI_COMM_WAVE, IERR_MPI) - IF (IPROC.ne.0) THEN - DO i=1,num_links_map1 - grid2_add_map1(i)=Asendi(i) - END DO - END IF - deallocate (Asendi) -! -! send wts_map1 -! - allocate (Asend(num_links_map1*num_wts)) - Asend=zero -! - ij=0 - IF (IPROC.eq.0) THEN - DO i=1,num_links_map1 - DO j=1,num_wts - ij=ij+1 - Asend(ij)=wts_map1(j,i) - END DO - END DO - END IF - ij=num_links_map1*num_wts - call mpi_bcast(Asend, ij, MPI_DOUBLE, & - & 0, MPI_COMM_WAVE, IERR_MPI) - IF (IPROC.ne.0) THEN - wts_map1=zero - ij=0 - DO i=1,num_links_map1 - DO j=1,num_wts - ij=ij+1 - wts_map1(j,i)=Asend(ij) - END DO - END DO - END IF - deallocate (Asend) - deallocate(Numlinks) -#endif -!----------------------------------------------------------------------- -! -! correct for situations where N/S pole not explicitly included in -! grid (i.e. as a grid corner point). if pole is missing from only -! one grid, need to correct only the area and centroid of that -! grid. if missing from both, do complete weight calculation. -! This is necessary only when integrating w.r.t. phi (longitude) -! -!----------------------------------------------------------------------- - - if (phi_or_theta .eq. 1) then - - !*** North Pole - weights(1) = pi2 - weights(2) = pi*pi - weights(3) = zero - weights(4) = pi2 - weights(5) = pi*pi - weights(6) = zero - - if (grid1_npole_cell /=0) then - grid1_area(grid1_npole_cell) = grid1_area(grid1_npole_cell) - & + weights(1) - grid1_centroid_lat(grid1_npole_cell) = - & grid1_centroid_lat(grid1_npole_cell) + weights(2) - grid1_centroid_lon(grid1_npole_cell) = - & grid1_centroid_lon(grid1_npole_cell) + weights(3) - endif - - if (grid2_npole_cell /=0) then - grid2_area(grid2_npole_cell) = grid2_area(grid2_npole_cell) - & + weights(num_wts+1) - grid2_centroid_lat(grid2_npole_cell) = - & grid2_centroid_lat(grid2_npole_cell) + - & weights(num_wts+2) - grid2_centroid_lon(grid2_npole_cell) = - & grid2_centroid_lon(grid2_npole_cell) + - & weights(num_wts+3) - endif - - if (grid1_npole_cell /= 0 .and. grid2_npole_cell /=0) then - call store_link_cnsrv(grid1_npole_cell, - & grid2_npole_cell, weights) - - grid1_frac(grid1_npole_cell) = grid1_frac(grid1_npole_cell) - & + weights(1) - grid2_frac(grid2_npole_cell) = grid2_frac(grid2_npole_cell) - & + weights(num_wts+1) - endif - - - !*** South Pole - weights(1) = pi2 - weights(2) = -pi*pi - weights(3) = zero - weights(4) = pi2 - weights(5) = -pi*pi - weights(6) = zero - - if (grid1_spole_cell /=0) then - grid1_area(grid1_spole_cell) = grid1_area(grid1_spole_cell) - & + weights(1) - grid1_centroid_lat(grid1_spole_cell) = - & grid1_centroid_lat(grid1_spole_cell) + weights(2) - grid1_centroid_lon(grid1_spole_cell) = - & grid1_centroid_lon(grid1_spole_cell) + weights(3) - endif - - if (grid2_spole_cell /=0) then - grid2_area(grid2_spole_cell) = grid2_area(grid2_spole_cell) - & + weights(num_wts+1) - grid2_centroid_lat(grid2_spole_cell) = - & grid2_centroid_lat(grid2_spole_cell) + - & weights(num_wts+2) - grid2_centroid_lon(grid2_spole_cell) = - & grid2_centroid_lon(grid2_spole_cell) + - & weights(num_wts+3) - endif - - if (grid1_spole_cell /= 0 .and. grid2_spole_cell /=0) then - call store_link_cnsrv(grid1_spole_cell, - & grid2_spole_cell, weights) - - grid1_frac(grid1_spole_cell) = grid1_frac(grid1_spole_cell) - & + weights(1) - grid2_frac(grid2_spole_cell) = grid2_frac(grid2_spole_cell) - & + weights(num_wts+1) - endif - endif - - - - if(is_master)print *, 'Grid sweeps completed' - - -!----------------------------------------------------------------------- -! -! finish centroid computation -! -!----------------------------------------------------------------------- - - call timer_start(3) - -C$OMP PARALLEL -C$OMP WORKSHARE - where (grid1_area /= zero) - grid1_centroid_lat = grid1_centroid_lat/grid1_area - grid1_centroid_lon = grid1_centroid_lon/grid1_area - end where -C$OMP END WORKSHARE - -C$OMP WORKSHARE - where (grid2_area /= zero) - grid2_centroid_lat = grid2_centroid_lat/grid2_area - grid2_centroid_lon = grid2_centroid_lon/grid2_area - end where -C$OMP END WORKSHARE -C$OMP END PARALLEL - - -!----------------------------------------------------------------------- -! -! include centroids in weights and normalize using destination -! area if requested -! -!----------------------------------------------------------------------- - -C$OMP PARALLEL DEFAULT(SHARED) NUM_THREADS(nthreads) -C$OMP& PRIVATE(n,grid1_add,grid2_add,nwgt,weights,norm_factor) - -C$OMP DO SCHEDULE(DYNAMIC) - - do n=1,num_links_map1 - grid1_add = grid1_add_map1(n) - grid2_add = grid2_add_map1(n) - do nwgt=1,num_wts - weights( nwgt) = wts_map1(nwgt,n) - if (num_maps > 1) then - weights(num_wts+nwgt) = wts_map2(nwgt,n) - endif - end do - - select case(norm_opt) - case (norm_opt_dstarea) - if (grid2_area(grid2_add) /= zero) then - if (luse_grid2_area) then - norm_factor = one/grid2_area_in(grid2_add) - else - norm_factor = one/grid2_area(grid2_add) - endif - else - norm_factor = zero - endif - case (norm_opt_frcarea) - if (grid2_frac(grid2_add) /= zero) then - if (luse_grid2_area) then - norm_factor = grid2_area(grid2_add)/ - & (grid2_frac(grid2_add)* - & grid2_area_in(grid2_add)) - else - norm_factor = one/grid2_frac(grid2_add) - endif - else - norm_factor = zero - endif - case (norm_opt_none) - norm_factor = one - end select - - wts_map1(1,n) = weights(1)*norm_factor - wts_map1(2,n) = (weights(2) - weights(1)* - & grid1_centroid_lat(grid1_add))* - & norm_factor - wts_map1(3,n) = (weights(3) - weights(1)* - & grid1_centroid_lon(grid1_add))* - & norm_factor - - if (num_maps > 1) then - select case(norm_opt) - case (norm_opt_dstarea) - if (grid1_area(grid1_add) /= zero) then - if (luse_grid1_area) then - norm_factor = one/grid1_area_in(grid1_add) - else - norm_factor = one/grid1_area(grid1_add) - endif - else - norm_factor = zero - endif - case (norm_opt_frcarea) - if (grid1_frac(grid1_add) /= zero) then - if (luse_grid1_area) then - norm_factor = grid1_area(grid1_add)/ - & (grid1_frac(grid1_add)* - & grid1_area_in(grid1_add)) - else - norm_factor = one/grid1_frac(grid1_add) - endif - else - norm_factor = zero - endif - case (norm_opt_none) - norm_factor = one - end select - - wts_map2(1,n) = weights(num_wts+1)*norm_factor - wts_map2(2,n) = (weights(num_wts+2) - weights(num_wts+1)* - & grid2_centroid_lat(grid2_add))* - & norm_factor - wts_map2(3,n) = (weights(num_wts+3) - weights(num_wts+1)* - & grid2_centroid_lon(grid2_add))* - & norm_factor - endif - - end do - -C$OMP END DO - -C$OMP END PARALLEL - - if(is_master)print *, 'Total number of links = ',num_links_map1 - -C$OMP PARALLEL -C$OMP WORKSHARE - where (grid1_area /= zero) grid1_frac = grid1_frac/grid1_area -C$OMP END WORKSHARE -C$OMP WORKSHARE - where (grid2_area /= zero) grid2_frac = grid2_frac/grid2_area -C$OMP END WORKSHARE -C$OMP END PARALLEL - - call timer_stop(3) - -!----------------------------------------------------------------------- -! -! perform some error checking on final weights -! -!----------------------------------------------------------------------- - - allocate(ref_area(grid1_size)) - allocate(reldiff(grid1_size)) - -C$OMP PARALLEL DEFAULT(SHARED) NUM_THREADS(nthreads) -C$OMP& PRIVATE(n, i, inext, beglat, beglon, endlat, endlon, weights) -C$OMP DO SCHEDULE(DYNAMIC) - - do n=1,grid1_size - if (grid1_area(n) < -.01 .and. is_master) then - print *,'Grid 1 area error: ',n,grid1_area(n) - endif - if ((grid1_centroid_lat(n) < -pih-.01 .or. - & grid1_centroid_lat(n) > pih+.01) .and. is_master) then - print *,'Grid 1 centroid lat error: ',n,grid1_centroid_lat(n) - endif - - ref_area(n) = 0.0 - do i = 1, grid1_corners - inext = 1 + mod(i,grid1_corners) - - beglat = grid1_corner_lat(i,n) - beglon = grid1_corner_lon(i,n) - endlat = grid1_corner_lat(inext,n) - endlon = grid1_corner_lon(inext,n) - - if ((phi_or_theta .eq. 1 .and. beglon .eq. endlon) .or. - & (phi_or_theta .eq. 2 .and. beglat .eq. endlat)) cycle - - call line_integral(phi_or_theta, weights, num_wts, beglon, - & endlon, beglat, endlat, grid1_center_lat(n), - & grid1_center_lon(n), grid1_center_lat(n), - & grid1_center_lon(n)) - - ref_area(n) = ref_area(n) + weights(1) - enddo - enddo -C$OMP END DO -C$OMP END PARALLEL - - -! Correct for polar cells - - if (phi_or_theta .eq. 1) then - - !*** North Pole - weights(1) = pi2 - - if (grid1_npole_cell /=0) then - ref_area(grid1_npole_cell) = ref_area(grid1_npole_cell) - & + weights(1) - endif - - !*** South Pole - weights(1) = pi2 - - if (grid1_spole_cell /=0) then - ref_area(grid1_spole_cell) = ref_area(grid1_spole_cell) - & + weights(1) - endif - - endif - - - ave_reldiff = 0.0 - max_reldiff = -1.0 - - do n = 1, grid1_size - if(ref_area(n).gt.0.0)then ! added May 21 2013 - reldiff(n) = abs(ref_area(n)-grid1_area(n))/abs(ref_area(n)) - endif - ave_reldiff = ave_reldiff + reldiff(n) - if (reldiff(n) > max_reldiff) then - max_reldiff = reldiff(n) - maxrd_cell = n - maxrd_area = grid1_area(n) - maxrd_true = ref_area(n) - endif - end do - - ave_reldiff = ave_reldiff/grid1_size - - if(is_master.and.l_test)then - print * - print * - print *,'Grid 1: Ave. rel. diff. in areas: ', - & ave_reldiff - print *,' rel. diff. = abs(area-refarea)/refarea' - print * - print *,'Grid 1: Max. rel. diff. in areas: ', - & max_reldiff - print *, 'Max rel. diff. is in cell ',maxrd_cell - print *, 'Computed Area: ', maxrd_area - print *, 'Reference Area: ',maxrd_true - print * - endif - - deallocate(ref_area, reldiff) - - - - allocate(ref_area(grid2_size)) - allocate(reldiff(grid2_size)) - -C$OMP PARALLEL DEFAULT(SHARED) NUM_THREADS(nthreads) -C$OMP& PRIVATE(n, i, inext, beglat, beglon, endlat, endlon, weights) -C$OMP DO SCHEDULE(DYNAMIC) - - do n=1,grid2_size - if (grid2_area(n) < -.01 .and. is_master) then - print *,'Grid 2 area error: ',n,grid2_area(n) - endif - if ((grid2_centroid_lat(n) < -pih-.01 .or. - & grid2_centroid_lat(n) > pih+.01) .and. is_master) then - print *,'Grid 2 centroid lat error: ',n,grid2_centroid_lat(n) - endif - - ref_area(n) = 0.0 - do i = 1, grid2_corners - inext = 1 + mod(i,grid2_corners) - - beglat = grid2_corner_lat(i,n) - beglon = grid2_corner_lon(i,n) - endlat = grid2_corner_lat(inext,n) - endlon = grid2_corner_lon(inext,n) - - if ((phi_or_theta .eq. 1 .and. beglon .eq. endlon) .or. - & (phi_or_theta .eq. 2 .and. beglat .eq. endlat)) cycle - - call line_integral(phi_or_theta, weights, num_wts, beglon, - & endlon, beglat, endlat, grid2_center_lat(n), - & grid2_center_lon(n), grid2_center_lat(n), - & grid2_center_lon(n)) - - ref_area(n) = ref_area(n) + weights(1) - enddo - enddo -C$OMP END DO -C$OMP END PARALLEL - - -! Correct for polar cells - - if (phi_or_theta .eq. 1) then - - !*** North Pole - weights(1) = pi2 - - if (grid2_npole_cell /=0) then - ref_area(grid2_npole_cell) = ref_area(grid2_npole_cell) - & + weights(1) - endif - - !*** South Pole - weights(1) = pi2 - - if (grid2_spole_cell /=0) then - ref_area(grid2_spole_cell) = ref_area(grid2_spole_cell) - & + weights(1) - endif - - endif - - - ave_reldiff = 0.0 - max_reldiff = -1.0 - - do n = 1, grid2_size - reldiff(n) = abs(ref_area(n)-grid2_area(n))/abs(ref_area(n)) - ave_reldiff = ave_reldiff + reldiff(n) - if (reldiff(n) > max_reldiff) then - max_reldiff = reldiff(n) - maxrd_cell = n - maxrd_area = grid2_area(n) - maxrd_true = ref_area(n) - endif - end do - - ave_reldiff = ave_reldiff/grid2_size - - if(is_master.and.l_test)then - print * - print *,'Grid 2: Ave. rel. diff. in areas: ', - & ave_reldiff - print *,' rel. diff. = abs(area-refarea)/refarea' - print * - print *,'Grid 2: Max. rel. diff. in areas: ', - & max_reldiff - print *, 'Max rel. diff. is in cell ',maxrd_cell - print *, 'Computed Area: ', maxrd_area - print *, 'Reference Area: ',maxrd_true - print * - endif - - deallocate(ref_area,reldiff) - - if(is_master.and.l_test)then - print *, 'Computed area = Area of cell computed by adding areas' - print *, ' of intersection with other cells' - print *, 'Reference area = Area of cell by direct integration' - print * - endif - - !*** - !*** In the following code, gridN_centroid_lat is being used to - !*** store running tallies of the cell areas - so it is a - !*** misnomer used to avoid allocation of a new variable - !*** - - grid1_centroid_lat = zero - grid2_centroid_lat = zero - icount=0 - -C$OMP PARALLEL DEFAULT(SHARED) NUM_THREADS(nthreads) -C$OMP& PRIVATE(n,grid1_add,grid2_add,nwgt,weights) -C$OMP DO SCHEDULE(DYNAMIC) - - do n=1,num_links_map1 - grid1_add = grid1_add_map1(n) - grid2_add = grid2_add_map1(n) - - do nwgt=1,num_wts - weights( nwgt) = wts_map1(nwgt,n) - if (num_maps > 1) then - weights(num_wts+nwgt) = wts_map2(nwgt,n) - endif - end do - -! count warnings about weights that will be excluded - if (grid2_frac(grid2_add).gt.frac_lowest .and. - & grid2_frac(grid2_add).lt.frac_highest .and. is_master) then - if ( (wts_map1(1,n) < wt_lowest) )then - icount=icount+1 -! print statements that were here have been moved to another routine... - endif - if (norm_opt /= norm_opt_none .and. wts_map1(1,n) > - & wt_highest)then - icount=icount+1 -! print statements that were here have been moved to another routine... - endif - endif -C$OMP CRITICAL - grid2_centroid_lat(grid2_add) = - & grid2_centroid_lat(grid2_add) + wts_map1(1,n) -C$OMP END CRITICAL - - if (num_maps > 1) then - if (wts_map2(1,n) < -.01 .and. is_master) then - print *,'Map 2 weight < 0 ',grid1_add,grid2_add, - & wts_map2(1,n) - endif - if (norm_opt /= norm_opt_none .and. wts_map2(1,n) > 1.01 - & .and. is_master) then - print *,'Map 2 weight > 1 ',grid1_add,grid2_add, - & wts_map2(1,n) - endif -C$OMP CRITICAL - grid1_centroid_lat(grid1_add) = - & grid1_centroid_lat(grid1_add) + wts_map2(1,n) -C$OMP END CRITICAL - endif - end do - -C$OMP END DO -C$OMP END PARALLEL - - if(icount.gt.0.and.is_master)then - print *,'We had problems in ',icount,' points.' - endif -! stop condition was here...has been moved to another routine... - - !*** - !*** If grid1 has masks, links between some cells of grid1 and - !*** grid2 do not exist even though they overlap. In such a case, - !*** the following code will generate errors even though nothing - !*** is wrong (grid1_centroid_lat or grid2_centroid_lat are never - !*** updated in the above loop) - !*** - - do n=1,grid2_size - select case(norm_opt) - case (norm_opt_dstarea) - norm_factor = grid2_frac(n) - case (norm_opt_frcarea) - norm_factor = one - case (norm_opt_none) - if (luse_grid2_area) then - norm_factor = grid2_area_in(n) - else - norm_factor = grid2_area(n) - endif - end select -! if (abs(grid2_centroid_lat(n)-norm_factor) > .01 -! & .and. is_master) then -! print *,'Warning: sum of wts for map1 ',n, -! & grid2_centroid_lat(n),norm_factor -! endif -! write(501,*)n,grid2_centroid_lat(n) - end do - - - if (num_maps > 1) then - do n=1,grid1_size - select case(norm_opt) - case (norm_opt_dstarea) - norm_factor = grid1_frac(n) - case (norm_opt_frcarea) - norm_factor = one - case (norm_opt_none) - if (luse_grid1_area) then - norm_factor = grid1_area_in(n) - else - norm_factor = grid1_area(n) - endif - end select - if (abs(grid1_centroid_lat(n)-norm_factor) > .01 - & .and. is_master) then - print *,'Error: sum of wts for map2 ',n, - & grid1_centroid_lat(n),norm_factor - endif - end do - endif -!----------------------------------------------------------------------- - - call timer_stop(4) - - if(is_master)print *, 'Finished Conservative Remapping' - - if(l_test)then - call timer_print(1) - call timer_print(2) - call timer_print(3) - call timer_print(4) - endif - - end subroutine remap_conserv - -!*********************************************************************** - - - -!*********************************************************************** - - subroutine cellblock_integrate(ibegin, iend, grid_num, - & phi_or_theta) - - integer (SCRIP_i4) :: ibegin, iend, grid_num, phi_or_theta - - integer (SCRIP_i4) :: cell_add - - - do cell_add = ibegin, iend - - call cell_integrate(cell_add, grid_num, phi_or_theta) - - enddo - - - - end subroutine cellblock_integrate - -!*********************************************************************** - - - -!*********************************************************************** - - subroutine cell_integrate(cell_add, grid_num, phi_or_theta) - -!----------------------------------------------------------------------- -! -! Integrate around cell while finding intersecting with opposite -! grid cells and finding segments of cell boundary lying in cells -! of opposite grid -! -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -! -! Input variables -! -!----------------------------------------------------------------------- - - integer (SCRIP_i4) :: - & cell_add, ! cell to be processed - & grid_num, ! grid that the cell belongs to - & phi_or_theta ! Integration var : - ! phi (lon) or theta (lat) - - -!----------------------------------------------------------------------- -! -! local variables -! -!----------------------------------------------------------------------- - - integer (SCRIP_i4), parameter :: - & max_subseg = 500 ! max number of subsegments per segment - ! to prevent infinite loop - - - integer (SCRIP_i4) :: - & i, inext, ! - & j, jnext, ! generic counters - & ic, k, ns, ! - & n, next_n, ! - & nwgt, it, ! - & oppcell_add, ! Cell from opposite grid we are - ! intersecting - & opp_grid_num, ! Index of opposite grid (2,1) - & min_add, ! addresses for restricting search of - & max_add, ! destination grid - & corner, ! corner of cell that segment starts - ! from - & next_corn, ! corner of cell that segment ends on - & nseg, ! number of segments to use to represent - ! edges near the pole - & num_subseg, ! number of subsegments - & bedgeid1, ! - & bedgeid2, ! ID of edge that a point is on - & bedgeid3, ! - & intedge, ! ID of intersected edge - & last_add, ! Address of last cell we were in - & next_add, ! Address of next cell we will go into - & adj_add ! Address of cell adjacent to current - ! one - - logical (SCRIP_logical) :: - & lcoinc, ! Are segments coincident? - & lrevers, ! Are we integrating segment in reverse? - & lboundary1, - & lboundary2, ! Is point is on cell boundary? - & lboundary3, - & last_lboundary, ! Is last point is on cell bdry? - & loutside, ! Is point outside the grid? - & lthresh, ! Has segment crossed threshold? - & srch_success, ! Was search for segment start - ! successful? - & intrsct_success, ! Was intersection of segment with - ! opposite grid successful? - & inpoly, ! Is point is in polygon - & last_endpt_inpoly, ! Was end point of last segment in cell - & last_endpt_onedge, ! Was end point of last segment on edge - ! of cell - & lstuck, ! Is the walk stuck inside a cell - & seg_outside, ! Is segment completely outside the grid - & bndedge, ! Is segment on the boundary of the grid - & search, ! Do we have to search to locate point - ! in grid - & inpolar, ! Are we in the polar region? - & special_cell, ! Is this a special cell - ! (only 1 vtx at pole) - & L_exit_do ! Do we need to escape from infinite - ! loop? (NRL) - - real (SCRIP_r8) :: - & intrsct_lat, ! lat of next intersection point - & intrsct_lon, ! lon of next intersection point - & beglat, beglon, ! start point of current sub seg - & endlat, endlon, ! endpoint of current seg - ! (chg to endseg?) - & endlat1, endlon1, ! endpoint of current subseg - & norm_factor ! factor for normalizing wts - - real (SCRIP_r8), dimension(2) :: - & begseg ! begin lat/lon for full segment - - real (SCRIP_r8), dimension(6) :: - & weights, ! local wgt array - & rev_weights ! Weights for grid1 and grid2 flipped - - real (SCRIP_r8) :: - & vec1_lat, vec1_lon, ! vectors, products - & vec2_lat, vec2_lon, ! used in grid search - & vec1_len, dp, - & midlat, midlon, ! Midpoint of segment - & tmplat, tmplon, - & srchpt_lat, ! Search point (offset from seg. start) - & srchpt_lon, - & offset, delta, ! Offset and offset increase for search - & sinang2, ! Square of sine of angle b/w two - ! segments - & dist2, ! Square of distance b/w two points - & fullseg_len2, ! Square of full segment length - & partseg_len2, ! Square of length of segment integrated - ! so far - & fullseg_dlat, ! Lat diff of full segment endpoints - & fullseg_dlon, ! Lon diff of full segment endpoints - & prevlon, - & nextlon, - & pole_lat, - & cell_center_lat, - & cell_center_lon, - & oppcell_center_lat, - & oppcell_center_lon - - real (SCRIP_r8), dimension(:), allocatable :: - & cell_corner_lat, ! Local copies of cell coordinates - & cell_corner_lon, ! May be augmented for computational - ! reasons - & oppcell_corner_lat, - & oppcell_corner_lon - - integer (SCRIP_i4) :: - & ncorners, ! Number of corners in local copy of cell - & ncorners_opp, ! Number of corners in local copy of oppcell - & nalloc, ! Allocation for the cell_corner_* array - & nalloc_opp ! Allocation for the oppcell_corner_* array - - real (SCRIP_r8) :: - & tmpwt1, tmpwt2 - - integer (SCRIP_i4) :: - & ncorners_at_pole, - & previdx, - & nextidx - - - if (grid_num .eq. 1) then - - !*** - !*** Set up a local copy of the cell with room to add - !*** degenerate edges - !*** - - ncorners = grid1_corners - nalloc = min(ncorners + 2, - & size(grid1_corner_lat(:,1))) - allocate (cell_corner_lat(nalloc), - & cell_corner_lon(nalloc)) - - do corner = 1, ncorners - cell_corner_lat(corner) = grid1_corner_lat(corner,cell_add) - cell_corner_lon(corner) = grid1_corner_lon(corner,cell_add) - enddo - - cell_center_lat = grid1_center_lat(cell_add) - cell_center_lon = grid1_center_lon(cell_add) - - special_cell = special_polar_cell1(cell_add) - - - !*** - !*** Also, allocate storage for the cell from the opposite grid - !*** - - opp_grid_num = 2 - ncorners_opp = grid2_corners - nalloc_opp = ncorners_opp+2 - allocate (oppcell_corner_lat(nalloc_opp), - & oppcell_corner_lon(nalloc_opp)) - - else - - !*** - !*** Set up the cell info with room to add degenerate edges - !*** - - ncorners = grid2_corners - nalloc = min(ncorners + 2, - & size(grid2_corner_lat(:,1))) - allocate (cell_corner_lat(nalloc), - & cell_corner_lon(nalloc)) - - do corner = 1, ncorners - cell_corner_lat(corner) = grid2_corner_lat(corner,cell_add) - cell_corner_lon(corner) = grid2_corner_lon(corner,cell_add) - enddo - - cell_center_lat = grid2_center_lat(cell_add) - cell_center_lon = grid2_center_lon(cell_add) - - special_cell = special_polar_cell2(cell_add) - - !*** - !*** Also, allocate storage for the cell from the opposite grid - !*** - - opp_grid_num = 1 - ncorners_opp = grid1_corners - nalloc_opp = ncorners_opp + 2 - allocate (oppcell_corner_lat(nalloc_opp), - & oppcell_corner_lon(nalloc_opp)) - - endif - - if (special_cell) then - - !*** - !*** Special cell with only one corner at the pole Such cells - !*** can have an artificially extreme distortion of the edges - !*** when mapped to the Lambert projection because of the span - !*** of longitudes on the edges So we will augment such cells - !*** with degenerate edges at the pole so that the edges coming - !*** off the pole will actually have the same longitude values - !*** at both ends - !*** - !*** lon_p lon_p+ lon_p lon_p- - !*** pi/2 pi/2 pi/2 pi/2 - !*** * *--------*------* - !*** / \ | | - !*** / \ | | - !*** / \ | | - !*** * * * * - !*** lon_p+ lon_p- lon_p+ lon_p- - !*** lat_p+ lat_p- lat_p+ lat_p- - !*** - - call modify_polar_cell(ncorners,nalloc,cell_corner_lat, - & cell_corner_lon) - - endif - - !*** - !*** Cell info set up - Now process the cell - !*** - - do corner = 1, ncorners - next_corn = mod(corner,ncorners) + 1 - - !*** - !*** define endpoints of the current segment - !*** - - beglat = cell_corner_lat(corner) - beglon = cell_corner_lon(corner) - endlat = cell_corner_lat(next_corn) - endlon = cell_corner_lon(next_corn) - lrevers = .false. - - !*** - !*** if this is a constant-longitude segment, skip the rest - !*** since the line integral contribution will be zero. - !*** - - if ((phi_or_theta == 1 .and. endlon == beglon) .or. - & (phi_or_theta == 2 .and. endlat == beglat)) cycle - - !*** - !*** to ensure exact path taken during both - !*** sweeps, always integrate segments in the same - !*** direction (SW to NE). - !*** - - if ((endlat < beglat) .or. - & (endlat == beglat .and. endlon < beglon)) then - tmplat = beglat - beglat = endlat - endlat = tmplat - tmplon = beglon - beglon = endlon - endlon = tmplon - lrevers = .not. lrevers - endif - - !*** But if one of the segment ends is in the polar region, - !*** we want to start from that (makes some logic easier) - - if ((beglat < north_thresh .and. endlat > north_thresh) .or. - & (beglat > south_thresh .and. endlat < south_thresh)) - & then - tmplat = beglat - beglat = endlat - endlat = tmplat - tmplon = beglon - beglon = endlon - endlon = tmplon - lrevers = .not. lrevers - endif - - begseg(1) = beglat - begseg(2) = beglon - - fullseg_dlat = endlat-beglat - fullseg_dlon = endlon-beglon - if (fullseg_dlon > pi) fullseg_dlon = fullseg_dlon - pi2 - if (fullseg_dlon < -pi) fullseg_dlon = fullseg_dlon + pi2 - fullseg_len2 = fullseg_dlat*fullseg_dlat + - & fullseg_dlon*fullseg_dlon - - partseg_len2 = 0.0 - - !*** - !*** Is this an edge on the boundary of the grid or - !*** on the boundary of the active cells - !*** - -! Commented out by MD -! call find_adj_cell(cell_add, corner, grid_num, adj_add) -! if (grid_num .eq. 1) then -! if (adj_add .eq. 0 .or. .not. grid1_mask(adj_add)) then -! bndedge = .true. -! else -! bndedge = .false. -! endif -! else -! if (adj_add .eq. 0 .or. .not. grid2_mask(adj_add)) then -! bndedge = .true. -! else -! bndedge = .false. -! endif -! endif - - call find_adj_cell(cell_add, corner, grid_num, adj_add) - bndedge = .false. - if (grid_num .eq. 1) then - if (adj_add .eq. 0) then - bndedge = .true. - else - if (.not. grid1_mask(adj_add)) then - bndedge = .true. - endif - endif - else - if (adj_add .eq. 0) then - bndedge = .true. - else - if (.not. grid2_mask(adj_add)) then - bndedge = .true. - endif - endif - endif - - !*** - !*** integrate along this segment, detecting intersections - !*** and computing the line integral for each sub-segment - !*** - - if (beglat .gt. north_thresh .or. beglat .lt. south_thresh) - & then - nseg = npseg ! Use multiple subsegments near the pole - inpolar = .true. - else - nseg = 1 - inpolar = .false. - endif - - - last_add = 0 - last_lboundary = .false. - last_endpt_inpoly = .false. - last_endpt_onedge = .false. - next_add = 0 - search = .true. - ns = 1 - -! outer "do while" - - do while (beglat /= endlat .or. beglon /= endlon) - - L_exit_do=.false. !NRL - - if ((ns .eq. nseg) .or. (inpolar .eqv. .false.)) then - ! - ! Last subseg or out of the polar region - ! Go directly to end of segment - ! - endlat1 = endlat - endlon1 = endlon - else - endlat1 = begseg(1) + ns*(fullseg_dlat)/nseg - endlon1 = begseg(2) + ns*(fullseg_dlon)/nseg - endif - - num_subseg = 0 - -! inner "do while" - - do while (beglat /= endlat1 .or. beglon /= endlon1) - - !*** - !*** If we integrated to the end or just past it (due to - !*** numerical errors), we are done with this segment - !*** - -!NRL see notes below re: infinite "do while" loop - L_exit_do=.false. !NRL - if (partseg_len2 .ge. fullseg_len2) then - write(*,*)'partseg_len2 .ge. fullseg_len2' - write(*,*)'beglat,beglon = ',beglat,beglon - write(*,*)'endlat,endlon = ',endlat,endlon - write(*,*)'endlat1,endlon1 = ',endlat1,endlon1 - write(*,*)'exiting inner do while loop' - L_exit_do=.true. !NRL - exit - end if - - !****************************************************** - !*** Try to find which cell of the opposite grid this - !*** segment is starting in and where it is exiting this - !*** cell - !****************************************************** - - vec1_lat = endlat1-beglat - vec1_lon = endlon1-beglon - if (vec1_lon > pi) vec1_lon = vec1_lon - pi2 - if (vec1_lon < -pi) vec1_lon = vec1_lon + pi2 - vec1_len = sqrt(vec1_lat*vec1_lat+vec1_lon*vec1_lon) - vec1_lat = vec1_lat/vec1_len - vec1_lon = vec1_lon/vec1_len - - offset = 100.0*tiny - oppcell_add = 0 - delta = 10*tiny - intrsct_success = .false. - loutside = .false. - lstuck = .false. - lboundary1 = .false. - lboundary2 = .false. - lboundary3 = .false. - - do while (.not. intrsct_success) - - !************************************************* - !*** Find out which cell the segment starts in - !************************************************* - - srch_success = .false. - if (search) then - - !*** - !*** Offset the start point in ever increasing - !*** amounts until we are able to reliably locate - !*** the point in a cell of grid2. Inability to locate - !*** the point causes the offset amount to increase - - it = 0 - do while (.not. srch_success) - - srchpt_lat = beglat + offset*vec1_lat - srchpt_lon = beglon + offset*vec1_lon - - call locate_point(srchpt_lat, srchpt_lon, - & cell_add, grid_num, opp_grid_num, - & oppcell_add, lboundary1, bedgeid1) - - if (oppcell_add .eq. 0) then - loutside = .true. -! lcoinc added by MD - lcoinc = .false. - exit ! exit the search loop - else - if (oppcell_add .ne. last_add .or. lthresh) - & then - srch_success = .true. - else - offset = offset + delta - if (offset .ge. vec1_len) then - exit - endif - if (it .gt. 3) then - delta = 2.0*delta - it = 0 - endif - endif - endif - - it = it + 1 - enddo ! do while (.not. srch_success) - - else - if (last_endpt_inpoly) then - - !*** We know the grid cell the end of the last - !*** segment (which is the beginning of this - !*** segment) - - oppcell_add = last_add - lboundary1 = last_lboundary - - else if (next_add .ne. 0) then - - !*** We know the edge of the grid2 cell that the - !*** last segment intersected, so we move into - !*** the adjacent cell - - oppcell_add = next_add - lboundary1 = .true. - - endif - - srch_success = .true. - - endif - - !***************************************************** - !*** Find where the segment exits this cell, if at all - !***************************************************** - - if (srch_success) then - - !*** - !*** First setup local copy of oppcell with room for - !*** adding degenerate edges - !*** - - if (grid_num .eq. 1) then - ncorners_opp = grid2_corners - do i = 1, ncorners_opp - oppcell_corner_lat(i) = - & grid2_corner_lat(i,oppcell_add) - oppcell_corner_lon(i) = - & grid2_corner_lon(i,oppcell_add) - enddo - oppcell_center_lat = - & grid2_center_lat(oppcell_add) - oppcell_center_lon = - & grid2_center_lon(oppcell_add) - - special_cell = special_polar_cell2(oppcell_add) - else - ncorners_opp = grid1_corners - do i = 1, ncorners_opp - oppcell_corner_lat(i) = - & grid1_corner_lat(i,oppcell_add) - oppcell_corner_lon(i) = - & grid1_corner_lon(i,oppcell_add) - enddo - oppcell_center_lat = - & grid1_center_lat(oppcell_add) - oppcell_center_lon = - & grid1_center_lon(oppcell_add) - - special_cell = special_polar_cell1(oppcell_add) - endif - - if (special_cell) then - call modify_polar_cell(ncorners_opp, nalloc_opp, - & oppcell_corner_lat, oppcell_corner_lon) - endif - - !*** - !*** First see if the segment end is - !*** in the same cell - !*** - - call ptincell(endlat1,endlon1, oppcell_add, - & ncorners_opp, - & oppcell_corner_lat,oppcell_corner_lon, - & oppcell_center_lat,oppcell_center_lon, - & opp_grid_num,inpoly, - & lboundary2,bedgeid2) - - if (inpoly) then - intrsct_lat = endlat1 - intrsct_lon = endlon1 - intrsct_success = .true. - search = .false. - next_add = 0 - last_add = oppcell_add ! for next subseg - last_lboundary = lboundary2 - last_endpt_inpoly = .true. - - if (lboundary1 .and. lboundary2) then - - !*** This is a edge on the boundary of the - !*** active mesh and both of its endpoints - !*** are on the boundary of the containing - !*** cell. Check if the the segment is also - !*** on the boundary - - midlat = (beglat+endlat1)/2.0 - if (abs(beglon-endlon1) .ge. pi) then - midlon = (beglon+endlon1)/2.0 - pi - else - midlon = (beglon+endlon1)/2.0 - endif - - call ptincell(midlat,midlon, oppcell_add, - & ncorners_opp, - & oppcell_corner_lat, oppcell_corner_lon, - & oppcell_center_lat, oppcell_center_lon, - & opp_grid_num, inpoly, lboundary3, - & bedgeid3) - - if (inpoly .and. lboundary3) then - lcoinc = .true. - intedge = bedgeid3 - endif - - else - lcoinc = .false. - endif - - else - - !*** - !*** Do an intersection to find out where the - !*** segment exits the cell - !*** - - call intersection(cell_add,grid_num, - & beglat, beglon, endlat1, endlon1, - & begseg, - & bedgeid1, - & oppcell_add, ncorners_opp, - & oppcell_corner_lat, oppcell_corner_lon, - & opp_grid_num, - & intrsct_lat, intrsct_lon, intedge, - & sinang2, lcoinc, lthresh) - - if (intedge /= 0) then - intrsct_success = .true. - last_add = oppcell_add ! for next subseg - last_endpt_onedge = .true. - last_endpt_inpoly = .false. - last_lboundary = .true. - - if (.not. lthresh) then - call find_adj_cell(oppcell_add,intedge, - & opp_grid_num,next_add) - if (next_add .ne. 0) then - search = .false. - else - search = .true. - endif - else - search = .true. - endif - endif - - endif - - if (.not. intrsct_success) then - - !*** Offset point and try again - - search = .true. - delta = 2.0*delta - offset = offset + delta - if (offset .gt. vec1_len) then - - ! Punt - exit the intersection loop - - intrsct_lat = endlat1 - intrsct_lon = endlon1 - last_add = 0 - last_lboundary = .false. - exit - - endif - endif - -!NRL if (lcoinc .and. .not. bndedge) then - - if (lcoinc .and. .not. bndedge !NRL - & .and. intedge /= 0) then !NRL - - !*** - !*** Segment is coincident with edge of other grid - !*** which means it could belong to one of 2 cells - !*** Choose the cell such that edge that is - !*** coincident with the segment is in the same - !*** dir as the segment - - i = intedge - inext = mod(i,ncorners_opp)+1 - vec2_lat = oppcell_corner_lat(inext) - - & oppcell_corner_lat(i) - vec2_lon = oppcell_corner_lon(inext) - - & oppcell_corner_lon(i) - - if (vec2_lon > pi) vec2_lon = vec2_lon - pi2 - if (vec2_lon < -pi) vec2_lon = vec2_lon + pi2 - - dp = vec1_lat*vec2_lat + vec1_lon*vec2_lon - - if ((.not. lrevers .and. dp .lt. 0) .or. - & (lrevers .and. dp .gt. 0)) then - - !*** Integrals from this segment must be - !*** assigned to the adjacent cell of - !*** opcell_add but only if such an adjacent - !*** cell exists - - call find_adj_cell(oppcell_add, intedge, - & opp_grid_num, adj_add) - - if (adj_add .gt. 0) then - oppcell_add = adj_add - - if (grid_num .eq. 1) then - ncorners_opp = grid2_corners - do i = 1, ncorners_opp - oppcell_corner_lat(i) = - & grid2_corner_lat(i,oppcell_add) - oppcell_corner_lon(i) = - & grid2_corner_lon(i,oppcell_add) - enddo - oppcell_center_lat = - & grid2_center_lat(oppcell_add) - oppcell_center_lon = - & grid2_center_lon(oppcell_add) - - special_cell = - & special_polar_cell2(oppcell_add) - else - ncorners_opp = grid1_corners - do i = 1, ncorners_opp - oppcell_corner_lat(i) = - & grid1_corner_lat(i,oppcell_add) - oppcell_corner_lon(i) = - & grid1_corner_lon(i,oppcell_add) - enddo - oppcell_center_lat = - & grid1_center_lat(oppcell_add) - oppcell_center_lon = - & grid1_center_lon(oppcell_add) - - special_cell = - & special_polar_cell1(oppcell_add) - endif - - if (special_cell) then - call modify_polar_cell(ncorners_opp, - & nalloc_opp, oppcell_corner_lat, - & oppcell_corner_lon) - endif - - endif - - endif - - endif - - else - - !*** - !*** Could not locate a viable cell for the segment - !*** start - !*** - - if (oppcell_add .eq. 0) then - loutside = .true. -! lcoinc added by MD - lcoinc = .false. - - !*** - !*** Take baby steps to see if any part of the - !*** segment is inside a cell of the other grid - !*** - - seg_outside = .false. - delta = vec1_len/100.00 - offset = delta - do while (.not. srch_success) - - srchpt_lat = beglat + offset*vec1_lat - srchpt_lon = beglon + offset*vec1_lon - - call locate_point(srchpt_lat, srchpt_lon, - & cell_add, grid_num, opp_grid_num, - & oppcell_add, lboundary1, bedgeid1) - - if (oppcell_add /= 0) then - srch_success = .true. - - !*** - !*** Found a point of the segment in the - !*** cell. Do a bisection method to find - !*** the starting point of the segment - !*** in the cell - !*** - - call converge_to_bdry(oppcell_add, - & opp_grid_num, ncorners_opp, - & oppcell_corner_lat, - & oppcell_corner_lon, - & oppcell_center_lat, - & oppcell_center_lon, - & srchpt_lat, srchpt_lon, - & beglat, beglon, - & intrsct_lat, intrsct_lon, - & bedgeid1) - - search = .false. - last_endpt_onedge = .true. - next_add = oppcell_add - last_lboundary = .true. - - oppcell_add = 0 - - else - - offset = offset + delta - - if (offset .ge. vec1_len) then -! print *, -! & 'Segment fully outside grid2' -! print *, 'Segment of grid1_add', -! & grid1_add -! print *, beglat,beglon -! print *, endlat1,endlon1 - - seg_outside = .true. - - intrsct_lat = endlat1 - intrsct_lon = endlon1 - - search = .true. - last_add = 0 - last_lboundary = .false. - - exit ! leave search loop - endif - endif - - enddo - - ! int. loop - if (srch_success .or. seg_outside) exit - - else - - if(is_master)then - print *, 'Unable to move out of last cell' - print *, 'Segment of edge ',corner, - & ' of grid cell ',cell_add - print *, 'Stuck in opposite grid cell ', - & oppcell_add - dist2 = - & (endlat1-begseg(1))*(endlat1-begseg(1)) + - & (endlon1-begseg(2))*(endlon1-begseg(2)) - print *, 'Fraction of segment left ', - & vec1_len/sqrt(dist2) - endif - lstuck = .true. - - !*** - !*** Punt - just assign the rest of the segment - !*** to the current cell it is stuck in by - !*** tagging the segment endpoint as the - !*** intersection point - !*** - - intrsct_lat = endlat1 - intrsct_lon = endlon1 - - search = .true. - last_add = 0 - last_lboundary = .false. - - endif - - exit ! exit the intersection loop - - endif ! if (srch_success) then ... else .... - - end do ! do while (.not. intrsct_success) - - !******************************************************** - !*** Compute the line integrals for this subsegment - !******************************************************** - - if (oppcell_add /= 0) then - call line_integral(phi_or_theta, weights, num_wts, - & beglon, intrsct_lon, beglat, intrsct_lat, - & cell_center_lat, cell_center_lon, - & oppcell_center_lat, oppcell_center_lon) - else - call line_integral(phi_or_theta, weights, num_wts, - & beglon, intrsct_lon, beglat, intrsct_lat, - & cell_center_lat, cell_center_lon, - & cell_center_lat, cell_center_lon) - endif - - !*** - !*** if integrating in reverse order, change - !*** sign of weights - !*** - - if (lrevers) then - weights = -weights - endif - - !*** - !*** store the appropriate addresses and weights. - !*** also add contributions to cell areas and centroids. - !*** - - if (grid_num .eq. 1) then - - if (oppcell_add /= 0) then - if (grid1_mask(cell_add)) then - call store_link_cnsrv(cell_add, oppcell_add, - & weights) - -C$OMP CRITICAL(block1) -! -! Could have another thread that found an intersection between that -! cell address and oppcell_add in which case it will try to write -! into this address - we have to block that until we are finished -! - grid1_frac(cell_add) = - & grid1_frac(cell_add) + weights(1) - - grid2_frac(oppcell_add) = - & grid2_frac(oppcell_add) + weights(num_wts+1) -C$OMP END CRITICAL(block1) - endif - - endif - -C$OMP CRITICAL(block2) - grid1_area(cell_add) = grid1_area(cell_add) + - & weights(1) - grid1_centroid_lat(cell_add) = - & grid1_centroid_lat(cell_add) + weights(2) - grid1_centroid_lon(cell_add) = - & grid1_centroid_lon(cell_add) + weights(3) -C$OMP END CRITICAL(block2) - - else - - !*** swap weights because in store_link_cnsrv - !*** we are always sending in grid1 weights first - !*** and then grid2 weights - - do i = 1, num_wts - rev_weights(num_wts+i) = weights(i) - rev_weights(i) = weights(num_wts+i) - enddo - - if (.not. lcoinc .and. oppcell_add /= 0) then - if (grid1_mask(oppcell_add)) then - call store_link_cnsrv(oppcell_add, cell_add, - & rev_weights) - -C$OMP CRITICAL(block3) -! -! Could have another thread that found an intersection between that -! cell address and oppcell_add in which case it will try to write -! into this address - we have to block that until we are finished -! - grid2_frac(cell_add) = - & grid2_frac(cell_add) + weights(1) - - grid1_frac(oppcell_add) = - & grid1_frac(oppcell_add) + weights(num_wts+1) -C$OMP END CRITICAL(block3) - - endif - - endif - -C$OMP CRITICAL(block4) - grid2_area(cell_add) = grid2_area(cell_add) + - & weights(1) - grid2_centroid_lat(cell_add) = - & grid2_centroid_lat(cell_add) + weights(2) - grid2_centroid_lon(cell_add) = - & grid2_centroid_lon(cell_add) + weights(3) -C$OMP END CRITICAL(block4) - endif - - !*** - !*** reset beglat and beglon for next subsegment. - !*** - - beglat = intrsct_lat - beglon = intrsct_lon - - !*** - !*** How far have we come from the start of the segment - !*** - - vec2_lat = intrsct_lat-begseg(1) - vec2_lon = intrsct_lon-begseg(2) - if (vec2_lon > pi) vec2_lon = vec2_lon - pi2 - if (vec2_lon < -pi) vec2_lon = vec2_lon + pi2 - - partseg_len2 = vec2_lat*vec2_lat + vec2_lon*vec2_lon - - !*** - !*** prevent infinite loops if integration gets stuck - !*** near cell or threshold boundary - !*** - - num_subseg = num_subseg + 1 - if (num_subseg > max_subseg) then - print *, - & 'integration stalled: num_subseg exceeded limit' - print *, 'Cell ',cell_add - print *, 'Edge ',corner - print *, 'Grid ',1 - dist2 = (endlat1-begseg(1))*(endlat1-begseg(1)) + - & (endlon1-begseg(2))*(endlon1-begseg(2)) - print *, 'Fraction of segment left ', - & vec1_len/sqrt(dist2) -! exit ! Give up and exit - stop ! Give up and stop - endif - -! inner "do while" - end do ! do while (beglat /= endlat1 ... - -!NRL We add an exit to outer do similar to exit of inner do: -!NRL This was an apparent bug: exit statement would escape -!NRL inner do but then computation could not get out of -!NRL outer do since beglat, beglon controlling outer do -!NRL never changed b/c it never gets to the part of the -!NRL code that changes beglat, beglon, b/c it keeps -!NRL exiting inner do. - -!NRL This should happen very rarely, so we have a print -!NRL statement to notify user. - - if (L_exit_do)then ! NRL - write(*,*)'partseg_len2,fullseg_len2 = ', ! NRL - & partseg_len2,fullseg_len2 ! NRL - write(*,*)'exiting outer do while loop' ! NRL - exit ! NRL - endif ! NRL - - ns = ns + 1 - if ((beglat > 0 .and. beglat < north_thresh) .or. - & (beglat < 0 .and. beglat > south_thresh)) - & then - inpolar = .false. - endif - -! outer "do while" - end do ! do while (beglat /= endlat .... - - call line_integral(phi_or_theta, weights, num_wts, - & begseg(2), endlon, begseg(1), endlat, - & cell_center_lat, - & cell_center_lon, - & cell_center_lat, - & cell_center_lon) - - !*** - !*** end of segment - !*** - - end do ! do corner=.... - - end subroutine cell_integrate -!*********************************************************************** - - -!*********************************************************************** - - subroutine modify_polar_cell(ncorners, nalloc, cell_corner_lat, - & cell_corner_lon) - - !*** Input variables - - integer (SCRIP_i4), intent(in) :: - & nalloc - - !*** In/Out Variables - - integer (SCRIP_i4), intent(inout) :: - & ncorners - real (SCRIP_r8), dimension(:), intent(inout) :: - & cell_corner_lat(nalloc), - & cell_corner_lon(nalloc) - - !*** Local variables - - integer (SCRIP_i4) :: - & npcorners, ! Number of polar corners - & pcorner, ! Index of the polar corner - ! (if only 1 is found) - & corner, ! Corner iterator variable - & previdx, ! Index of previous corner to polar corner - & nextidx ! Index of next corner to polar corner - - real (SCRIP_r8) :: - & pole_lat, ! Latitude considered to be pole - & prevlon, ! Latitude of previous corner to polar corner - & nextlon ! Latitude of next corner to polar corner - - - !*** - !*** Modify special cell with only one corner at the pole. Such - !*** cells can have an artificially extreme distortion of the - !*** edges when mapped to the Lambert projection because of the - !*** span of longitudes on the edges So we will augment such - !*** cells with degenerate edges at the pole so that the edges - !*** coming off the pole will actually have the same longitude - !*** values at both ends - !*** - !*** lon_p lon_p+ lon_p lon_p- - !*** pi/2 pi/2 pi/2 pi/2 - !*** * *--------*------* - !*** / \ | | - !*** / \ | | - !*** / \ | | - !*** * * * * - !*** lon_p+ lon_p- lon_p+ lon_p- - !*** lat_p+ lat_p- lat_p+ lat_p- - !*** - - - !*** - !*** MAJOR ASSUMPTION HERE IS THAT CELL_CORNER_LAT AND - !*** CELL_CORNER_LON HAVE ROOM TO GROW - !*** - if (ncorners .ge. nalloc) return ! ** * No room to grow - - pcorner = 0 - npcorners = 0 - do corner = 1, ncorners - if (abs(abs(cell_corner_lat(corner))-pih) .le. 1.0e-05) then - pcorner = corner - pole_lat = cell_corner_lat(corner) - npcorners = npcorners + 1 - endif - enddo - - - if (npcorners .ne. 1) return !*** Not the kind of cell we want - - previdx = mod((pcorner-1)-1+ncorners,ncorners) + 1 - prevlon = cell_corner_lon(previdx) - - nextidx = mod(pcorner,ncorners) + 1 - nextlon = cell_corner_lon(nextidx) - - !*** Move entries from pcorner+1 on back by one - - do corner = ncorners, pcorner+1, -1 - cell_corner_lat(corner+1) = cell_corner_lat(corner) - cell_corner_lon(corner+1) = cell_corner_lon(corner) - enddo - - !*** Add a corner after pcorner - - cell_corner_lat(pcorner+1) = pole_lat - cell_corner_lon(pcorner+1) = nextlon - - ncorners = ncorners+1 - - !*** Move entries from pcorner on back by one - - do corner = ncorners, pcorner, -1 - cell_corner_lat(corner+1) = cell_corner_lat(corner) - cell_corner_lon(corner+1) = cell_corner_lon(corner) - enddo - - !*** Add a corner before pcorner - - cell_corner_lat(pcorner) = pole_lat - cell_corner_lon(pcorner) = prevlon - - ncorners = ncorners+1 - - end subroutine modify_polar_cell - - -!*********************************************************************** - - subroutine intersection(seg_cell_id, seg_grid_id, - & beglat, beglon, endlat, endlon, begseg, begedge, - & cell_id, ncorners, cell_corner_lat, - & cell_corner_lon, cell_grid_id, intrsct_lat, intrsct_lon, - & intedge, sinang2, lcoinc, lthresh) - -!----------------------------------------------------------------------- -! -! this routine finds the intersection of a line segment given by -! beglon, endlon, etc. with a cell from another grid -! A coincidence flag is returned if the segment is entirely -! coincident with an edge of the opposite. -! -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -! -! intent(in): -! -!----------------------------------------------------------------------- - - integer (SCRIP_i4), intent(in) :: - & seg_cell_id ! ID of cell that intersecting segment is from - - integer (SCRIP_i4), intent(in) :: - & seg_grid_id ! ID of grid that intersecting segment is from - - real (SCRIP_r8), intent(in) :: - & beglat, beglon,! beginning lat/lon endpoints for segment - & endlat, endlon ! ending lat/lon endpoints for segment - - real (SCRIP_r8), dimension(2), intent(inout) :: - & begseg ! begin lat/lon of full segment - - integer (SCRIP_i4), intent(in) :: - & begedge ! edge that beginning point is on (can be 0) - - integer (SCRIP_i4), intent(in) :: - & cell_id ! cell to intersect with - - integer (SCRIP_i4), intent(in) :: - & ncorners ! number of corners of cell - - real (SCRIP_r8), dimension(ncorners), intent(in) :: - & cell_corner_lat, ! coordinates of cell corners - & cell_corner_lon - - integer (SCRIP_i4), intent(in) :: - & cell_grid_id ! which grid is the cell from? - - -!----------------------------------------------------------------------- -! -! intent(out): -! -!----------------------------------------------------------------------- - - real (SCRIP_r8), intent(out) :: - & intrsct_lat, - & intrsct_lon ! lat/lon coords of intersection - - real (SCRIP_r8), intent(out) :: - & sinang2 ! square of sine of angle between - ! intersecting lines - - integer (SCRIP_i4), intent(out) :: - & intedge ! edge that is intersected - - logical (SCRIP_logical), intent(out) :: - & lcoinc ! True if segment is coincident with - ! a cell edge - - logical (SCRIP_logical), intent(out) :: - & lthresh ! True if segment crosses threshold - -!----------------------------------------------------------------------- -! -! local variables -! -!----------------------------------------------------------------------- - - integer (SCRIP_i4) :: - & n, next_n - - logical (SCRIP_logical) :: - & found, first - - real (SCRIP_r8) :: - & lon1, lon2, ! local longitude variables for segment - & lat1, lat2, ! local latitude variables for segment - & grdlon1, grdlon2, ! local longitude variables for grid cell - & grdlat1, grdlat2, ! local latitude variables for grid cell - & vec1_lat, vec1_lon, - & vec2_lat, vec2_lon, ! - & vec3_lat, vec3_lon, ! vectors and vector products used - & cross_product, ! during grid search - & dot_product, ! - & lensqr1, lensqr2, ! - & lensqr3, ! - & s1, s2, determ, - & mat1, mat2, ! variables used for linear solve to - & mat3, mat4, ! find intersection - & rhs1, rhs2, ! - & denom, - & begsegloc(2), ! local copy of full segment start - & dist2, ! distance from start pt to intersection - ! pt - & maxdist2, ! max dist from start pt to any - ! intersection pt - & max_intrsct_lat, ! latitude of farthest intersection point - & max_intrsct_lon, ! longitude of farthest intersection - ! point - & minlat, maxlat, ! min and max latitudes of segment - & minlon, maxlon, ! min and max longitudes of segment - & tmplat, tmplon - - -!----------------------------------------------------------------------- -! -! initialize defaults, flags, etc. -! -!----------------------------------------------------------------------- - - lcoinc = .false. - lthresh = .false. - intedge = 0 - first = .true. - - lat1 = beglat - lon1 = beglon - lat2 = endlat - lon2 = endlon - - ! No edge is allowed to span more than pi radians - ! Accordingly transform one or the other end point - - if ((lon2-lon1) > pi) then - lon2 = lon2 - pi2 - else if ((lon2-lon1) < -pi) then - lon1 = lon1 - pi2 - endif - s1 = zero - -!----------------------------------------------------------------------- -! -! loop over sides of the cell to find intersection with side -! must check all sides for coincidences or intersections -! -!----------------------------------------------------------------------- - - if (beglat > north_thresh .or. beglat < south_thresh) then - - !*** Special intersection routine for cells near the pole - !*** Intersection is done in a transformed space using - !*** multi-segmented representation of the cell - - call pole_intersection(cell_id,ncorners, - & cell_corner_lat,cell_corner_lon,cell_grid_id, - & beglat, beglon, endlat, - & endlon, begseg, begedge, - & intedge,intrsct_lat,intrsct_lon, - & sinang2,lcoinc,lthresh) - - return - - endif - - - maxdist2 = -9999999.0 - - begsegloc(1) = begseg(1) - begsegloc(2) = begseg(2) - - lthresh = .false. - intrsct_loop: do n=1,ncorners - next_n = mod(n,ncorners) + 1 - - grdlat1 = cell_corner_lat(n) - grdlon1 = cell_corner_lon(n) - grdlat2 = cell_corner_lat(next_n) - grdlon2 = cell_corner_lon(next_n) - - lensqr2 = (grdlat1-grdlat2)*(grdlat1-grdlat2) + - & (grdlon1-grdlon2)*(grdlon1-grdlon2) - - if (lensqr2 .le. tiny*tiny) cycle ! degenerate edge - - ! No edge can span more than pi radians - - if (grdlon2-grdlon1 > pi) then - grdlon2 = grdlon2 - pi2 - else if (grdlon2-grdlon1 < -pi) then - grdlon1 = grdlon1 - pi2 - endif - - ! Also the two intersecting segments together - ! cannot span more than 2*pi radians - - minlon = min(lon1,lon2) - maxlon = max(grdlon1,grdlon2) - if (maxlon-minlon > pi2) then - grdlon1 = grdlon1 - pi2 - grdlon2 = grdlon2 - pi2 - else - minlon = min(grdlon1,grdlon2) - maxlon = max(lon1,lon2) - if (maxlon-minlon > pi2) then - grdlon1 = grdlon1 + pi2 - grdlon2 = grdlon2 + pi2 - endif - endif - - - !*** - !*** set up linear system to solve for intersection - !*** - - mat1 = lat2 - lat1 - mat2 = grdlat1 - grdlat2 - mat3 = lon2 - lon1 - mat4 = grdlon1 - grdlon2 - rhs1 = grdlat1 - lat1 - rhs2 = grdlon1 - lon1 - - determ = mat1*mat4 - mat2*mat3 - - !*** - !*** if the determinant is zero, the segments are either - !*** parallel or coincident. coincidences were detected - !*** above so do nothing. - - if (abs(determ) > tiny*tiny) then - - !*** if the determinant is non-zero, solve for the linear - !*** parameters s for the intersection point on each line - !*** segment. - !*** if 0= zero .and. s2 <= one .and. - & s1 > zero .and. s1 <= one) then - - !*** - !*** recompute intersection based on full segment - !*** so intersections are consistent for both sweeps - !*** - - if (lon2-begsegloc(2) > pi) then - lon2 = lon2 - pi2 - else if (lon2-begsegloc(2) < -pi) then - begsegloc(2) = begsegloc(2) - pi2 - endif - - - ! Also the two intersecting segments together - ! cannot span more than 2*pi radians - - minlon = min(begsegloc(2),lon2) - maxlon = max(grdlon1,grdlon2) - if (maxlon-minlon > pi2) then - grdlon1 = grdlon1 - pi2 - grdlon2 = grdlon2 - pi2 - else - minlon = min(grdlon1,grdlon2) - maxlon = max(begsegloc(2),lon2) - if (maxlon-minlon > pi2) then - grdlon1 = grdlon1 + pi2 - grdlon2 = grdlon2 + pi2 - endif - endif - - - mat1 = lat2 - begsegloc(1) - mat3 = lon2 - begsegloc(2) - rhs1 = grdlat1 - begsegloc(1) - rhs2 = grdlon1 - begsegloc(2) - - determ = mat1*mat4 - mat2*mat3 - - !*** - !*** sometimes due to roundoff, the previous - !*** determinant is non-zero, but the lines - !*** are actually coincident. if this is the - !*** case, skip the rest. - !*** - - if (determ /= zero) then - s1 = (rhs1*mat4 - mat2*rhs2)/determ - s2 = (mat1*rhs2 - rhs1*mat3)/determ - - intrsct_lat = begsegloc(1) + mat1*s1 - intrsct_lon = begsegloc(2) + mat3*s1 - - if (intrsct_lon < 0.0) then - intrsct_lon = intrsct_lon + pi2 - else if (intrsct_lon > pi2) then - intrsct_lon = intrsct_lon - pi2 - endif - - !*** - !*** Make sure the intersection point is not within - !*** tolerance of the starting point - !*** - - if (first) then - max_intrsct_lat = intrsct_lat - max_intrsct_lon = intrsct_lon - - vec1_lat = intrsct_lat-beglat - vec1_lon = intrsct_lon-beglon - if (vec1_lon > pi) then - vec1_lon = vec1_lon - pi2 - else if (vec1_lon < -pi) then - vec1_lon = vec1_lon + pi2 - endif - - maxdist2 = vec1_lat*vec1_lat + vec1_lon*vec1_lon - dist2 = maxdist2 - - denom = (mat1*mat1+mat2*mat2)*(mat3*mat3+mat4*mat4) - sinang2 = determ*determ/denom - intedge = n - first = .false. - else - vec1_lat = intrsct_lat-beglat - vec1_lon = intrsct_lon-beglon - if (vec1_lon > pi) then - vec1_lon = vec1_lon - pi2 - else if (vec1_lon < -pi) then - vec1_lon = vec1_lon + pi2 - endif - - dist2 = vec1_lat*vec1_lat + vec1_lon*vec1_lon - - if (dist2 > maxdist2) then - if (begedge .eq. 0 .or. begedge .ne. n) then - max_intrsct_lat = intrsct_lat - max_intrsct_lon = intrsct_lon - maxdist2 = dist2 - - denom = - & (mat1*mat1+mat2*mat2)*(mat3*mat3+mat4*mat4) - sinang2 = determ*determ/denom - intedge = n - endif - endif - endif - - else - print *, 'DEBUG: zero determ' - stop - endif - - endif - - else - - !*** - !*** Coincident lines or parallel lines - !*** - - cross_product = mat2*rhs2 - mat4*rhs1 - - !*** - !*** If area of triangle formed by endlat,endlon and - !*** the gridline is negligible then the lines are coincident - !*** - - - if (abs(cross_product) < tiny) then - - dot_product = mat1*(-mat2) + mat3*(-mat4) - - lensqr1 = mat1*mat1 + mat3*mat3 ! length sqrd of input - ! segment - - if (dot_product < zero) then - - !*** - !*** Segments oriented in the same direction - !*** - - - tmplat = grdlat2 - tmplon = grdlon2 - grdlat2 = grdlat1 - grdlon2 = grdlon1 - grdlat1 = tmplat - grdlon1 = tmplon - - endif - - - vec2_lat = grdlat1 - lat1 - vec2_lon = grdlon1 - lon1 - if (vec2_lon > pi) vec2_lon = vec2_lon - pi2 - if (vec2_lon < -pi) vec2_lon = vec2_lon + pi2 - - lensqr2 = vec2_lat*vec2_lat + vec2_lon*vec2_lon - - if (vec2_lat*mat1 + vec2_lon*mat3 < 0) then - lensqr2 = -lensqr2 - endif - - vec3_lat = grdlat2 - lat1 - vec3_lon = grdlon2 - lon1 - if (vec3_lon > pi) vec3_lon = vec3_lon - pi2 - if (vec3_lon < -pi) vec3_lon = vec3_lon + pi2 - - lensqr3 = (vec3_lat*vec3_lat+vec3_lon*vec3_lon) - - if (vec3_lat*mat1 + vec3_lon*mat3 < 0) then - lensqr3 = -lensqr3 - endif - - found = .false. - - if (lensqr2 > 0) then - if (lensqr2 <= lensqr1) then - intrsct_lat = grdlat1 - intrsct_lon = grdlon1 - found = .true. - endif - else - if (lensqr3 > 0) then - if (lensqr3 > lensqr1) then - intrsct_lat = lat2 - intrsct_lon = lon2 - found = .true. - else - intrsct_lat = grdlat2 - intrsct_lon = grdlon2 - found = .true. - endif - endif - endif - - if (found) then - - dist2 = (intrsct_lat-beglat)*(intrsct_lat-beglat)+ - & (intrsct_lon-beglon)*(intrsct_lon-beglon) - - !*** Coincidence intersection always wins - - max_intrsct_lat = intrsct_lat - max_intrsct_lon = intrsct_lon - maxdist2 = dist2 - sinang2 = 0 - intedge = n - lcoinc = .true. - - exit intrsct_loop - endif - - endif - - endif - - !*** restore lon1 and lon2 in case it got modified - - lon1 = beglon - lon2 = endlon - begsegloc(2) = begseg(2) - if ((lon2-lon1) > pi) then - lon2 = lon2 - pi2 - else if ((lon2-lon1) < -pi) then - lon1 = lon1 - pi2 - endif - - end do intrsct_loop - - if (intedge .eq. 0) then - return - else - if (maxdist2 < 1e6*tiny*tiny) then - intedge = 0 - return - else - intrsct_lat = max_intrsct_lat - intrsct_lon = max_intrsct_lon - endif - endif - -!----------------------------------------------------------------------- -! -! if the segment crosses a pole threshold, reset the intersection -! to be the threshold latitude. only check if this was not a -! threshold segment since sometimes coordinate transform can end -! up on other side of threshold again. -! -!----------------------------------------------------------------------- - - if (lthresh) then - if (intrsct_lat < north_thresh .or. intrsct_lat > south_thresh) - & lthresh = .false. - else if (lat1 > zero .and. intrsct_lat > north_thresh) then -! intrsct_lat = north_thresh + tiny - intrsct_lat = north_thresh - mat1 = lat2 - begsegloc(1) - mat3 = lon2 - begsegloc(2) - s1 = (intrsct_lat - begsegloc(1))/mat1 - intrsct_lon = begsegloc(2) + s1*mat3 - lthresh = .true. - else if (lat1 < zero .and. intrsct_lat < south_thresh) then -! intrsct_lat = south_thresh - tiny - intrsct_lat = south_thresh - mat1 = lat2 - begsegloc(1) - mat3 = lon2 - begsegloc(2) - s1 = (intrsct_lat - begsegloc(1))/mat1 - intrsct_lon = begsegloc(2) + s1*mat3 - lthresh = .true. - endif - - if (intrsct_lon < 0.0) then - intrsct_lon = intrsct_lon + pi2 - else if (intrsct_lon > pi2) then - intrsct_lon = intrsct_lon - pi2 - endif - - -!----------------------------------------------------------------------- - - end subroutine intersection - -!*********************************************************************** - - - subroutine pole_intersection(location,ncorners, - & cell_corners_lat,cell_corners_lon,cell_grid_id, - & beglat, beglon, endlat, endlon, begseg, begedge, - & intedge, intrsct_lat, intrsct_lon, - & sinang2, lcoinc, lthresh) - -!----------------------------------------------------------------------- -! -! Special intersection routine for line segment in cell close to -! poles -! A coordinate transformation (using a Lambert azimuthal -! equivalent projection) is performed to perform the intersection -! Also, since a straight line in lat-lon space is a curve in this -! transformed space, we represent each edge of the cell as having -! 'npseg' segments whose endpoints are mapped using the Lambert -! projection -! -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -! -! intent(in): -! -!----------------------------------------------------------------------- - - integer (SCRIP_i4), intent(in) :: - & location ! cell to intersect segment with - - integer (SCRIP_i4), intent(in) :: - & ncorners ! Number of cell corners - - real (SCRIP_r8), dimension(ncorners), intent(in) :: - & cell_corners_lat, ! Cell corner coordinates - & cell_corners_lon - - integer (SCRIP_i4), intent(in) :: - & cell_grid_id ! which grid is the cell from? - - real (SCRIP_r8), intent(in) :: - & beglat, beglon, ! beginning lat/lon coords for segment - & endlat, endlon ! ending lat/lon coords for segment - - real (SCRIP_r8), dimension(2), intent(inout) :: - & begseg ! begin lat/lon of full segment - - integer (SCRIP_i4), intent(in) :: - & begedge ! edge on which segment start is on - ! (can be 0) - -!----------------------------------------------------------------------- -! -! intent(out): -! -!----------------------------------------------------------------------- - - integer (SCRIP_i4), intent(out) :: - & intedge ! Edge that segment intersects - - real (SCRIP_r8), intent(out) :: - & intrsct_lat, ! lat/lon coords of intersection - & intrsct_lon - - real (SCRIP_r8), intent(out) :: - & sinang2 ! square of sine of angle between - ! intersecting line segments - - logical (SCRIP_logical), intent(out) :: - & lcoinc ! True if segment is coincident with - ! a cell edge - - logical (SCRIP_logical), intent(inout) :: - & lthresh ! True if segment crosses threshold - - -!----------------------------------------------------------------------- -! -! local variables -! -!----------------------------------------------------------------------- - - integer (SCRIP_i4) :: - & n, n1, next_n, prev_n, - & it, i, j, - & ncorners2, - & intedge1 - - logical (SCRIP_logical) :: - & first, - & found - - real (SCRIP_r8) :: - & pi4, rns, ! north/south conversion - & x1, x2, ! local x variables for segment - & y1, y2, ! local y variables for segment - & grdx1, grdx2, ! local x variables for grid cell - & grdy1, grdy2, ! local y variables for grid cell - & grdlat1, grdlat2, ! latitude vars for grid cell - & grdlon1, grdlon2, ! longitude vars for grid cell - & vec1_y, vec1_x, ! - & vec2_y, vec2_x, ! vectors and cross products used - & vec3_y, vec3_x, ! - & vec1_lat, vec1_lon, ! - & vec2_lat, vec2_lon, ! - & vec3_lon, ! - & cross_product, ! - & dot_product, ! - & s1, s2, determ, ! variables used for linear solve to - & mat1, mat2, ! - & mat3, mat4, ! find intersection - & rhs1, rhs2, ! - & denom, ! - & intrsct_x, intrsct_y, ! intersection coordinates in - ! transformed space - & max_intrsct_lat, ! intersection point at max distance - & max_intrsct_lon, ! from the start point - & dist2, ! dist of intersection point from start - ! point - & maxdist2, ! max dist of intersection point from - ! start pnt - & lensqr1, lensqr2, ! various segment lengths - & lensqr3, - & tmpx, tmpy, - & tmplat, tmplon, - & ldummy - - !*** - !*** variables necessary if segment manages to hit pole - !*** - - real (SCRIP_r8), dimension(npseg*ncorners) :: - & cell_corners_lat_loc,! Lat/Lon coordinates of multi-segmented - & cell_corners_lon_loc ! version of cell - - - -!----------------------------------------------------------------------- -! -! initialize defaults, flags, etc. -! -!----------------------------------------------------------------------- - - max_intrsct_lat = pi ! intersection point at max distance - max_intrsct_lon = 4*pi ! from the start point - - intedge = 0 - first = .true. - maxdist2 = -999999.00 - - s1 = zero - -!----------------------------------------------------------------------- -! -! convert coordinates -! -!----------------------------------------------------------------------- - - if (beglat > zero) then - pi4 = quart*pi - rns = one - else - pi4 = -quart*pi - rns = -one - endif - - x1 = rns*two*sin(pi4 - half*beglat)*cos(beglon) - y1 = two*sin(pi4 - half*beglat)*sin(beglon) - x2 = rns*two*sin(pi4 - half*endlat)*cos(endlon) - y2 = two*sin(pi4 - half*endlat)*sin(endlon) - - intrsct_x = x2 - intrsct_y = y2 - - -!----------------------------------------------------------------------- -! -! now that a cell is found, search for the next intersection. -! loop over sides of the cell to find intersection with side -! must check all sides for coincidences or intersections -! -!----------------------------------------------------------------------- - - - if (abs(x1) .le. tiny .and. abs(y1) .le. tiny .and. - & abs(x2) .le. tiny .and. abs(y2) .le. tiny) then - - !*** - !*** The segment is a polar segment which is degenerate - !*** in the transformed Lambert space. Find out which - !*** cell edge it is coincident with and find the - !*** point where the segment exits this cell (if at all) - !*** NOTE 1: THIS MUST BE DONE IN LAT-LON SPACE - !*** NOTE 2: CODE RELEVANT ONLY FOR INTEGRATION W.R.T. phi - !*** - - intrsct_loop1: do n = 1, ncorners - next_n = mod(n,ncorners) + 1 - - grdlat1 = cell_corners_lat(n) - grdlon1 = cell_corners_lon(n) - grdlat2 = cell_corners_lat(next_n) - grdlon2 = cell_corners_lon(next_n) - grdx1 = rns*two*sin(pi4 - half*grdlat1)*cos(grdlon1) - grdy1 = two*sin(pi4 - half*grdlat1)*sin(grdlon1) - grdx2 = rns*two*sin(pi4 - half*grdlat2)*cos(grdlon2) - grdy2 = two*sin(pi4 - half*grdlat2)*sin(grdlon2) - - if (abs(grdx1) .le. tiny .and. abs(grdy1) .le. tiny .and. - & abs(grdx2) .le. tiny .and. abs(grdy2) .le. tiny) then - - !*** - !*** Found polar segment in cell - !*** - - vec1_lon = endlon-beglon - if (vec1_lon .gt. pi) vec1_lon = vec1_lon - pi2 - if (vec1_lon .lt. -pi) vec1_lon = vec1_lon + pi2 - - vec2_lon = grdlon2-grdlon1 - if (vec2_lon .gt. pi) vec2_lon = vec2_lon - pi2 - if (vec2_lon .lt. -pi) vec2_lon = vec2_lon + pi2 - - if (vec1_lon*vec2_lon .lt. 0) then - - !*** switch coordinates to simplify logic below - - tmplat = grdlat2 - tmplon = grdlon2 - grdlat2 = grdlat1 - grdlon2 = grdlon1 - grdlat1 = tmplat - grdlon1 = tmplon - endif - - vec2_lon = grdlon1 - beglon - if (vec2_lon .gt. pi) vec2_lon = vec2_lon - pi2 - if (vec2_lon .lt. -pi) vec2_lon = vec2_lon + pi2 - - vec3_lon = grdlon2 - beglon - if (vec3_lon .gt. pi) vec3_lon = vec3_lon - pi2 - if (vec3_lon .lt. -pi) vec3_lon = vec3_lon + pi2 - - found = .false. - - if (vec2_lon*vec1_lon > 0) then - if (abs(vec3_lon) < abs(vec1_lon)) then - intrsct_lon = grdlon2 - found = .true. - else if (abs(vec2_lon) < abs(vec1_lon)) then - intrsct_lon = grdlon1 ! Shouldn't be here - found = .true. - endif - else - if (vec3_lon*vec1_lon > 0) then - if (abs(vec3_lon) < abs(vec1_lon)) then - intrsct_lon = grdlon2 - found = .true. - endif - endif - - endif - - if (found) then - intrsct_lat = endlat - lcoinc = .true. - sinang2 = 0.0 - intedge = n - exit intrsct_loop1 - endif - - endif - - end do intrsct_loop1 - - return - endif - - - - - !**** - !**** General intersection - !**** - - - - !*** - !*** Construct multi-segmented version of the cell - !*** - - i = 0 - do n = ncorners, 1, -1 - i = i+1 - n1 = mod(n,ncorners)+1 - cell_corners_lat_loc(i) = cell_corners_lat(n1) - cell_corners_lon_loc(i) = cell_corners_lon(n1) - - prev_n = n1-1 - if (prev_n .eq. 0) prev_n = ncorners ! how do we do (j-1+n)%n - ! in F90 ? - - vec1_lat = cell_corners_lat(prev_n)-cell_corners_lat(n1) - vec1_lon = cell_corners_lon(prev_n)-cell_corners_lon(n1) - if (vec1_lon > pi) then - vec1_lon = vec1_lon - pi2 - else if (vec1_lon < -pi) then - vec1_lon = vec1_lon + pi2 - endif - - do j = 1, npseg-1 - i = i+1 - cell_corners_lat_loc(i) = - & cell_corners_lat(n1) + j*vec1_lat/npseg - cell_corners_lon_loc(i) = - & cell_corners_lon(n1) + j*vec1_lon/npseg - enddo - enddo - - ncorners2 = npseg*ncorners - - - - !*** - !*** Now intersect segment with multi-segmented version of cell - !*** - - - intrsct_loop2: do n= 1, ncorners2 - - next_n = mod(n,ncorners2) + 1 - - grdlat1 = cell_corners_lat_loc(n) - grdlon1 = cell_corners_lon_loc(n) - grdlat2 = cell_corners_lat_loc(next_n) - grdlon2 = cell_corners_lon_loc(next_n) - grdx1 = rns*two*sin(pi4 - half*grdlat1)*cos(grdlon1) - grdy1 = two*sin(pi4 - half*grdlat1)*sin(grdlon1) - grdx2 = rns*two*sin(pi4 - half*grdlat2)*cos(grdlon2) - grdy2 = two*sin(pi4 - half*grdlat2)*sin(grdlon2) - - if ((grdx1-grdx2)*(grdx1-grdx2)+(grdy1-grdy2)*(grdy1-grdy2) .le. - & tiny*tiny) cycle - - - !*** - !*** set up linear system to solve for intersection - !*** - - mat1 = x2 - x1 - mat2 = grdx1 - grdx2 - mat3 = y2 - y1 - mat4 = grdy1 - grdy2 - rhs1 = grdx1 - x1 - rhs2 = grdy1 - y1 - - determ = mat1*mat4 - mat2*mat3 - - !*** - !*** if the determinant is zero, the segments are either - !*** parallel or coincident or one segment has zero length. - - !*** if the determinant is non-zero, solve for the linear - !*** parameters s for the intersection point on each line - !*** segment. - !*** if 0 1.e-30) then - - s1 = (rhs1*mat4 - mat2*rhs2)/determ - s2 = (mat1*rhs2 - rhs1*mat3)/determ - - if (s2 >= zero .and. s2 <= one .and. - & s1 > tiny .and. s1 <= one) then - - intrsct_x = x1 + s1*mat1 - intrsct_y = y1 + s1*mat3 - - !*** - !*** convert back to lat/lon coordinates - !*** - - if (abs(intrsct_x) .gt. tiny .or. - & abs(intrsct_y) .gt. tiny) then - - intrsct_lon = rns*atan2(intrsct_y,intrsct_x) - - else - - !*** Degenerate case - we don't have a good way of - !*** finding out what the longitude corresponding - !*** to a (0,0) intersection is. So we take the - !*** the intersection as one of the two endpoints of - !*** the grid segment - - if (abs(abs(grdlat1)-pih) .lt. 1e-5 .and. - & abs(abs(grdlat2)-pih) .lt. 1e-5) then - - !*** Both endpoints of the grid segment are at the pole - !*** but at different longitudes - - vec1_lat = grdlat1-beglat - vec1_lon = grdlon1-beglon - if (vec1_lon > pi) then - vec1_lon = vec1_lon - pi2 - else if (vec1_lon < -pi) then - vec1_lon = vec1_lon + pi2 - endif - dist2 = vec1_lat*vec1_lat + vec1_lon*vec1_lon - - vec2_lat = grdlat2-beglat - vec2_lon = grdlon2-beglon - if (vec2_lon > pi) then - vec2_lon = vec2_lon - pi2 - else if (vec2_lon < -pi) then - vec2_lon = vec2_lon + pi2 - endif - - !*** pick the endpoint of the grid segment that is - !*** farthest from the beg point of the segment - - if ((vec1_lat*vec1_lat + vec1_lon*vec1_lon) .ge. - & (vec2_lat*vec2_lat + vec2_lon*vec2_lon)) then - intrsct_lon = grdlon1 - else - intrsct_lon = grdlon2 - endif - - else if (abs(abs(grdlat1)-pih) .lt. 1e-5) then - intrsct_lon = grdlon1 - else if (abs(abs(grdlat2)-pih) .lt. 1e-5) then - intrsct_lon = grdlon2 - endif - - !*** Make sure this longitude is not outside the - !*** beglon,endlon range - - vec1_lon = endlon-intrsct_lon - if (vec1_lon > pi) then - vec1_lon = vec1_lon - pi2 - else if (vec1_lon < -pi) then - vec1_lon = vec1_lon + pi2 - endif - - vec2_lon = beglon-intrsct_lon - if (vec2_lon > pi) then - vec2_lon = vec2_lon - pi2 - else if (vec2_lon < -pi) then - vec2_lon = vec2_lon + pi2 - endif - - !*** if vec1_lon and vec2_lon are of the same sign - !*** then intrsct_lon is outside the beglon,endlon - !*** range - - if (vec1_lon*vec2_lon > 0) cycle - - endif - - if (intrsct_lon < zero) - & intrsct_lon = intrsct_lon + pi2 - - if (abs(intrsct_x) > 1.d-10) then - intrsct_lat = (pi4 - - & asin(rns*half*intrsct_x/cos(intrsct_lon)))*two - ldummy = two*(pi4 - - & asin(sqrt(intrsct_x*intrsct_x+intrsct_y*intrsct_y)/2.)) - else if (abs(intrsct_y) > 1.d-10) then - intrsct_lat = (pi4 - - & asin(half*intrsct_y/sin(intrsct_lon)))*two - ldummy = two*(pi4 - - & asin(sqrt(intrsct_x*intrsct_x+intrsct_y*intrsct_y)/2.)) - else - intrsct_lat = two*pi4 - endif - - - !*** - !*** If there are multiple intersection points, accept the - !*** one that is not on the edge we started from but is - !*** closest to the start point - need this for - !*** intersection to work for non-convex edges - !*** - - if (first) then - - intedge1 = (n-1)/npseg + 1 - intedge1 = ncorners - intedge1 + 1 ! dir of edges was - ! reversed - if (intedge1 .ne. begedge) then - - max_intrsct_lat = intrsct_lat - max_intrsct_lon = intrsct_lon - - vec1_lat = intrsct_lat-beglat - vec1_lon = intrsct_lon-beglon - if (vec1_lon > pi) then - vec1_lon = vec1_lon - pi2 - else if (vec1_lon < -pi) then - vec1_lon = vec1_lon + pi2 - endif - maxdist2 = vec1_lat*vec1_lat + vec1_lon*vec1_lon - dist2 = maxdist2 - - denom = (mat1*mat1+mat2*mat2)*(mat3*mat3+mat4*mat4) - sinang2 = determ*determ/denom - intedge = intedge1 - - first = .false. - endif - - else - vec1_lat = intrsct_lat-beglat - vec1_lon = intrsct_lon-beglon - if (vec1_lon > pi) then - vec1_lon = vec1_lon - pi2 - else if (vec1_lon < -pi) then - vec1_lon = vec1_lon + pi2 - endif - dist2 = vec1_lat*vec1_lat + vec1_lon*vec1_lon - - !*** if the first intersection was on the same edge - !*** as the starting edge or - !*** the current intersection point is not on the - !*** starting edge and the distance to the beginning - !*** point is less than that of the previous - !*** intersection accept this intersection - - intedge1 = (n-1)/npseg + 1 - intedge1 = ncorners - intedge1 + 1 ! dir of edges was - ! reversed - if (dist2 > maxdist2) then - if (begedge == 0 .or. intedge1 .ne. begedge) then - max_intrsct_lat = intrsct_lat - max_intrsct_lon = intrsct_lon - maxdist2 = dist2 - - denom = - & (mat1*mat1+mat2*mat2)*(mat3*mat3+mat4*mat4) - sinang2 = determ*determ/denom - intedge = intedge1 - endif - endif - endif - endif - - else - - !*** - !*** Coincident lines or parallel lines - !*** - - cross_product = mat2*rhs2 - mat4*rhs1 - - if (abs(cross_product) < tiny) then - - dot_product = mat1*(-mat2) + mat3*(-mat4) - - !*** - !*** If area of triangle formed by x2,y2 and the gridline - !*** is negligible then the lines are coincident - !*** - - lensqr1 = mat1*mat1 + mat3*mat3 ! length sqrd of input - ! segment - - if (dot_product < zero) then - tmpx = grdx2 - tmpy = grdy2 - tmplat = grdlat2 - tmplon = grdlon2 - grdx2 = grdx1 - grdy2 = grdy1 - grdlat2 = grdlat1 - grdlon2 = grdlon1 - grdx1 = tmpx - grdy1 = tmpy - grdlat1 = tmplat - grdlon1 = tmplon - endif - - - vec2_x = grdx1 - x1 - vec2_y = grdy1 - y1 - lensqr2 = vec2_x*vec2_x + vec2_y*vec2_y - if (vec2_x*mat1+vec2_y*mat3 < 0) then - lensqr2 = -lensqr2 - endif - - - vec3_x = grdx2 - x1 - vec3_y = grdy2 - y1 - lensqr3 = (vec3_x*vec3_x+vec3_y*vec3_y) - if (vec3_x*mat1+vec3_y*mat3 < 0) then - lensqr3 = -lensqr3 - endif - - found = .false. - - if (lensqr2 > 0) then - if (lensqr2 <= lensqr1) then - intrsct_x = grdx1 - intrsct_y = grdy1 - intrsct_lat = grdlat1 - intrsct_lon = grdlon1 - found = .true. - endif - else - if (lensqr3 > 0) then - if (lensqr3 > lensqr1) then - intrsct_x = x2 - intrsct_y = y2 - intrsct_lat = endlat - intrsct_lon = endlon - found = .true. - else - intrsct_x = grdx2 - intrsct_y = grdy2 - intrsct_lat = grdlat2 - intrsct_lon = grdlon2 - found = .true. - endif - endif - endif - - if (found) then - dist2 = (intrsct_lat-beglat)*(intrsct_lat-beglat)+ - & (intrsct_lon-beglon)*(intrsct_lon-beglon) - - if (dist2 > tiny*tiny) then - - !*** Coincidence intersection always wins - - max_intrsct_lat = intrsct_lat - max_intrsct_lon = intrsct_lon - maxdist2 = dist2 - sinang2 = 0 - intedge = (n-1)/npseg + 1 - intedge = ncorners - intedge + 1 - lcoinc = .true. - - exit intrsct_loop2 - endif - endif - - - endif ! if (abs(cross_product) < tiny) - - endif ! if (abs(determ) > 1.e-30) .. else .. endif - - end do intrsct_loop2 - - if (maxdist2 < 1e6*tiny*tiny) then - intedge = 0 - return - else - intrsct_lat = max_intrsct_lat - intrsct_lon = max_intrsct_lon - endif - -!----------------------------------------------------------------------- -! -! if segment manages to cross over pole, shift the beginning -! endpoint in order to avoid hitting pole directly -! (it is ok for endpoint to be pole point) -! -!----------------------------------------------------------------------- - - if (abs(intrsct_x) < 1.e-10 .and. abs(intrsct_y) < 1.e-10 .and. - & (x2 /= zero .and. y2 /=0)) then - if (avoid_pole_count > 2) then - avoid_pole_count = 0 - avoid_pole_offset = 10.*avoid_pole_offset - endif - - cross_product = x1*(y2-y1) - y1*(x2-x1) - intrsct_lat = beglat - if (cross_product*intrsct_lat > zero) then - intrsct_lon = beglon + avoid_pole_offset - else - intrsct_lon = beglon - avoid_pole_offset - endif - - avoid_pole_count = avoid_pole_count + 1 - else - avoid_pole_count = 0 - avoid_pole_offset = tiny - endif - -!----------------------------------------------------------------------- -! -! if the segment crosses a pole threshold, reset the intersection -! to be the threshold latitude and do not reuse x,y intersect -! on next entry. only check if did not cross threshold last -! time - sometimes the coordinate transformation can place a -! segment on the other side of the threshold again -! -!----------------------------------------------------------------------- - - if (lthresh) then - if (intrsct_lat > north_thresh .or. intrsct_lat < south_thresh) - & lthresh = .false. - else if (beglat > zero .and. intrsct_lat < north_thresh) then - mat4 = endlat - begseg(1) - mat3 = endlon - begseg(2) - if (mat3 > pi) mat3 = mat3 - pi2 - if (mat3 < -pi) mat3 = mat3 + pi2 -! intrsct_lat = north_thresh - tiny - intrsct_lat = north_thresh - s1 = (north_thresh - begseg(1))/mat4 - intrsct_lon = begseg(2) + s1*mat3 - lthresh = .true. - else if (beglat < zero .and. intrsct_lat > south_thresh) then - mat4 = endlat - begseg(1) - mat3 = endlon - begseg(2) - if (mat3 > pi) mat3 = mat3 - pi2 - if (mat3 < -pi) mat3 = mat3 + pi2 -! intrsct_lat = south_thresh + tiny - intrsct_lat = south_thresh - s1 = (south_thresh - begseg(1))/mat4 - intrsct_lon = begseg(2) + s1*mat3 - lthresh = .true. - endif - - -!----------------------------------------------------------------------- - - end subroutine pole_intersection - -!*********************************************************************** - - - - subroutine line_integral(phi_or_theta, weights, num_wts, - & in_phi1, in_phi2, theta1, theta2, - & grid1_lat, grid1_lon, grid2_lat, grid2_lon) - -!----------------------------------------------------------------------- -! -! this routine computes the line integral of the flux function -! that results in the interpolation weights. the line is defined -! by the input lat/lon of the endpoints. -! -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -! -! intent(in): -! -!----------------------------------------------------------------------- - - integer (SCRIP_i4), intent(in) :: - & phi_or_theta ! Integration variable (lat or lon) - - integer (SCRIP_i4), intent(in) :: - & num_wts ! number of weights to compute - - real (SCRIP_r8), intent(in) :: - & in_phi1, in_phi2, ! longitude endpoints for the segment - & theta1, theta2, ! latitude endpoints for the segment - & grid1_lat, grid1_lon, ! reference coordinates for each - & grid2_lat, grid2_lon ! grid (to ensure correct 0,2pi interv. - -!----------------------------------------------------------------------- -! -! intent(out): -! -!----------------------------------------------------------------------- - - real (SCRIP_r8), dimension(2*num_wts), intent(out) :: - & weights ! line integral contribution to weights - - -! write(*,*)'subroutine line_integral' - if (phi_or_theta .eq. 1) then - call line_integral_phi(weights, num_wts, in_phi1, in_phi2, - & theta1, theta2, grid1_lat, grid1_lon, - & grid2_lat, grid2_lon) - else - call line_integral_theta(weights, num_wts,in_phi1,in_phi2, - & theta1, theta2, grid1_lat, grid1_lon, - & grid2_lat, grid2_lon) - endif - - - return - -!----------------------------------------------------------------------- - - end subroutine line_integral - -!*********************************************************************** - - - - subroutine line_integral_phi(weights, num_wts, - & in_phi1, in_phi2, theta1, theta2, - & grid1_lat, grid1_lon, grid2_lat, grid2_lon) - -!----------------------------------------------------------------------- -! -! this routine computes the line integral of the flux function -! that results in the interpolation weights. the line is defined -! by the input lat/lon of the endpoints. Integration is w.r.t. lon -! -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -! -! intent(in): -! -!----------------------------------------------------------------------- - - integer (SCRIP_i4), intent(in) :: - & num_wts ! number of weights to compute - - real (SCRIP_r8), intent(in) :: - & in_phi1, in_phi2, ! longitude endpoints for the segment - & theta1, theta2, ! latitude endpoints for the segment - & grid1_lat, grid1_lon, ! reference coordinates for each - & grid2_lat, grid2_lon ! grid (to ensure correct 0,2pi interv. - -!----------------------------------------------------------------------- -! -! intent(out): -! -!----------------------------------------------------------------------- - - real (SCRIP_r8), dimension(2*num_wts), intent(out) :: - & weights ! line integral contribution to weights - -!----------------------------------------------------------------------- -! -! local variables -! -!----------------------------------------------------------------------- - - real (SCRIP_r8) :: dphi, sinth1, sinth2, costh1, costh2, fac, - & phi1, phi2 - real (SCRIP_r8) :: f1, f2, fint - -!----------------------------------------------------------------------- -! -! weights for the general case based on a trapezoidal approx to -! the integrals. -! -!----------------------------------------------------------------------- - - -! write(*,*)'subroutine line_integral_phi' - - sinth1 = SIN(theta1) - sinth2 = SIN(theta2) - costh1 = COS(theta1) - costh2 = COS(theta2) - - dphi = in_phi1 - in_phi2 - if (dphi > pi) then - dphi = dphi - pi2 - else if (dphi < -pi) then - dphi = dphi + pi2 - endif - dphi = half*dphi - -!----------------------------------------------------------------------- -! -! the first weight is the area overlap integral. the second and -! fourth are second-order latitude gradient weights. -! -!----------------------------------------------------------------------- - - weights( 1) = dphi*(sinth1 + sinth2) - write(401,*)weights(1),' % A' - weights(num_wts+1) = dphi*(sinth1 + sinth2) - weights( 2) = dphi*(costh1 + costh2 + (theta1*sinth1 + - & theta2*sinth2)) - weights(num_wts+2) = dphi*(costh1 + costh2 + (theta1*sinth1 + - & theta2*sinth2)) - -!----------------------------------------------------------------------- -! -! the third and fifth weights are for the second-order phi gradient -! component. must be careful of longitude range. -! -!----------------------------------------------------------------------- - - f1 = half*(costh1*sinth1 + theta1) - f2 = half*(costh2*sinth2 + theta2) - - phi1 = in_phi1 - grid1_lon - if (phi1 > pi) then - phi1 = phi1 - pi2 - else if (phi1 < -pi) then - phi1 = phi1 + pi2 - endif - - phi2 = in_phi2 - grid1_lon - if (phi2 > pi) then - phi2 = phi2 - pi2 - else if (phi2 < -pi) then - phi2 = phi2 + pi2 - endif - - if ((phi2-phi1) < pi .and. (phi2-phi1) > -pi) then - weights(3) = dphi*(phi1*f1 + phi2*f2) - else - if (phi1 > zero) then - fac = pi - else - fac = -pi - endif - fint = f1 + (f2-f1)*(fac-phi1)/abs(dphi) - weights(3) = half*phi1*(phi1-fac)*f1 - - & half*phi2*(phi2+fac)*f2 + - & half*fac*(phi1+phi2)*fint - endif - - phi1 = in_phi1 - grid2_lon - if (phi1 > pi) then - phi1 = phi1 - pi2 - else if (phi1 < -pi) then - phi1 = phi1 + pi2 - endif - - phi2 = in_phi2 - grid2_lon - if (phi2 > pi) then - phi2 = phi2 - pi2 - else if (phi2 < -pi) then - phi2 = phi2 + pi2 - endif - - if ((phi2-phi1) < pi .and. (phi2-phi1) > -pi) then - weights(num_wts+3) = dphi*(phi1*f1 + phi2*f2) - else - if (phi1 > zero) then - fac = pi - else - fac = -pi - endif - fint = f1 + (f2-f1)*(fac-phi1)/abs(dphi) - weights(num_wts+3) = half*phi1*(phi1-fac)*f1 - - & half*phi2*(phi2+fac)*f2 + - & half*fac*(phi1+phi2)*fint - endif - -!----------------------------------------------------------------------- - - end subroutine line_integral_phi - -!*********************************************************************** - - - -!*********************************************************************** - - subroutine line_integral_theta(weights, num_wts, - & in_phi1, in_phi2, theta1, theta2, - & grid1_lat, grid1_lon, grid2_lat, grid2_lon) - -!----------------------------------------------------------------------- -! -! this routine computes the line integral of the flux function -! that results in the interpolation weights. the line is defined -! by the input lat/lon of the endpoints. Integration is w.r.t. lat -! -! Needed to use Simpson rule for this integration to get lower errors -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -! -! intent(in): -! -!----------------------------------------------------------------------- - - integer (SCRIP_i4), intent(in) :: - & num_wts ! number of weights to compute - - real (SCRIP_r8), intent(in) :: - & in_phi1, in_phi2, ! longitude endpoints for the segment - & theta1, theta2, ! latitude endpoints for the segment - & grid1_lat, grid1_lon, ! reference coordinates for each - & grid2_lat, grid2_lon ! grid (to ensure correct 0,2pi interv. - -!----------------------------------------------------------------------- -! -! intent(out): -! -!----------------------------------------------------------------------- - - real (SCRIP_r8), dimension(2*num_wts), intent(out) :: - & weights ! line integral contribution to weights - -!----------------------------------------------------------------------- -! -! local variables -! -!----------------------------------------------------------------------- - - real (SCRIP_r8) :: dtheta, dtheta2, costh1, costh2, costhpi, - & phi1, phi2, theta_pi, f1, f2, fpi, - & fm, costhm, part1, part2 - -!----------------------------------------------------------------------- -! -! weights for the general case based on a trapezoidal approx to -! the integrals. -! -!----------------------------------------------------------------------- - - costh1 = COS(theta1) - costh2 = COS(theta2) - costhm = COS(half*(theta1+theta2)) - - dtheta = theta2 - theta1 - dtheta2 = half*dtheta - -! write(*,*)' subroutine line_integral_theta' - - -!----------------------------------------------------------------------- -! -! Need to account for double value of longitude in calculations of -! all the weights. First we transform all the phis to be relative -! to the grid center This takes care of a good number of cases where -! the the phis span the periodic boundary in the longitudinal -! direction. If we still have a line that spans the periodic -! boundary then we have to integrate along the line in two parts - -! from point 1 to the periodic boundary and from the periodic -! boundary to the second point -! -! Example: Consider a line which has points at phi1 = -100 and phi2 -! = 100 degrees and say the grid center is at phi_c = 0 -! degrees. Then phi1-phi_c > -180 and phi2-phi_c < 180. But -! phi2-phi1 > 180. -! -! *********************************************!!!!!!!!!!! -! If we are doing the second step anyway, why are we normalizing the -! coordinates with respect to the grid centers? -! -! We need it particularly in this integration because phi figures -! explicitly in the expressions - so if a cell straddles the 0,2pi -! boundary, we integrate some edges with phi values close to zero -! and others with phi values close to 2pi leading to errors -! *********************************************!!!!!!!!!!! -! -!----------------------------------------------------------------------- - - phi1 = in_phi1 - grid1_lon - if (phi1 > pi) then - phi1 = phi1 - pi2 - else if (phi1 < -pi) then - phi1 = phi1 + pi2 - endif - - phi2 = in_phi2 - grid1_lon - if (phi2 > pi) then - phi2 = phi2 - pi2 - else if (phi2 < -pi) then - phi2 = phi2 + pi2 - endif - - f1 = phi1*costh1 - f2 = phi2*costh2 - - if ((phi2-phi1) < pi .and. (phi2-phi1) > -pi) then - - fm = half*(phi1+phi2)*costhm - - weights(1) = dtheta*(f1 + 4*fm + f2)/6.0 -! write(401,*)weights(1),' % A' - - weights(2) = dtheta2*(theta1*f1 + theta2*f2) - - weights(3) = half*dtheta2*(f1*f1 + f2*f2) - - else - if (phi1 > zero) then ! Means phi2-phi1 < -pi - -! theta at phi = pi - theta_pi = theta1 + (pi - phi1)*dtheta/(phi2 + pi2 - phi1) -! print *, '' -! print *, 'phi1',phi1,' phi2',phi2 -! print *, 'theta1',theta1,' theta2',theta2 -! print *, 'theta_pi',theta_pi - - costhpi = COS(theta_pi) - fpi = pi*costhpi - - fm = half*(phi1+pi)*cos(half*(theta1+theta_pi)) - part1 = (theta_pi - theta1)*(f1 + 4*fm + fpi)/6.0 - - fm = half*(phi2-pi)*cos(half*(theta1+theta_pi)) - part2 = 0.5*(theta2 - theta_pi)*(-fpi + 4*fm + f2)/6.0 - - weights(1) = part1 + part2 -! write(401,*)weights(1),' % B' - - part1 = 0.5*(theta_pi - theta1)*(theta1*f1 + theta_pi*fpi) - part2 = 0.5*(theta2 - theta_pi)*(-theta_pi*fpi + theta2*f2) - weights(2) = part1 + part2 - - - else ! Means phi2-phi1 > pi - -! theta at phi = -pi - theta_pi = theta1 + (-pi - phi1)*dtheta/(phi2 - pi2 - phi1) -! print *, '' -! print *, 'phi1',phi1,' phi2',phi2 -! print *, 'theta1',theta1,' theta2',theta2 -! print *, 'theta_pi',theta_pi - - costhpi = COS(theta_pi) - fpi = pi*costhpi - - fm = half*(phi1-pi)*cos(half*(theta1+theta_pi)) - part1 = 0.5*(theta_pi - theta1)*(f1 + 4*fm - fpi)/6.0 - - fm = half*(pi+phi2)*cos(half*(theta2+theta_pi)) - part2 = 0.5*(theta2 - theta_pi)*(fpi + 4*fm + f2)/6.0 - weights(1) = part1 + part2 -! write(401,*)weights(1),' % C' - - part1 = 0.5*(theta_pi - theta1)*(theta1*f1 - theta_pi*fpi) - part2 = 0.5*(theta2 - theta_pi)*(theta_pi*fpi + theta2*f2) - weights(2) = part1 + part2 - - - endif - - part1 = 0.25*(theta_pi - theta1)*(f1*f1 + fpi*fpi) - part2 = 0.25*(theta2 - theta_pi)*(fpi*fpi + f2*f2) - weights(3) = part1 + part2 - - endif - - - phi1 = in_phi1 - grid2_lon - if (phi1 > pi) then - phi1 = phi1 - pi2 - else if (phi1 < -pi) then - phi1 = phi1 + pi2 - endif - - phi2 = in_phi2 - grid2_lon - if (phi2 > pi) then - phi2 = phi2 - pi2 - else if (phi2 < -pi) then - phi2 = phi2 + pi2 - endif - - - f1 = phi1*costh1 - f2 = phi2*costh2 - - if ((phi2-phi1) < pi .and. (phi2-phi1) > -pi) then - - fm = half*(phi1+phi2)*costhm - - weights(num_wts+1) = dtheta2*(f1 + f2) - - weights(num_wts+2) = dtheta2*(theta1*f1 + theta2*f2) - - weights(num_wts+3) = half*dtheta2*(f1*f1 + f2*f2) - - else - if (phi1 > zero) then - - theta_pi = theta1 + (pi - phi1)*dtheta/(phi2 + pi2 - phi1) -! print *, '' -! print *, 'phi1',phi1,' phi2',phi2 -! print *, 'theta1',theta1,' theta2',theta2 -! print *, 'theta_pi',theta_pi - - costhpi = COS(theta_pi) - fpi = pi*costhpi - - fm = half*(phi1+pi)*cos(half*(theta1+theta_pi)) - part1 = (theta_pi - theta1)*(f1 + 4*fm + fpi)/6.0 - - fm = half*(-pi+phi2)*cos(half*(theta2+theta_pi)) - part2 = (theta2 - theta_pi)*(-fpi + 4*fm + f2)/6.0 - weights(num_wts+1) = part1 + part2 - - part1 = 0.5*(theta_pi - theta1)*(theta1*f1 + theta_pi*fpi) - part2 = 0.5*(theta2 - theta_pi)*(-theta_pi*fpi + theta2*f2) - weights(num_wts+2) = part1 + part2 - - - else - - theta_pi = theta1 + (-pi - phi1)*dtheta/(phi2 - pi2 - phi1) -! print *, '' -! print *, 'phi1',phi1,' phi2',phi2 -! print *, 'theta1',theta1,' theta2',theta2 -! print *, 'theta_pi',theta_pi - - costhpi = COS(theta_pi) - fpi = pi*costhpi - - fm = half*(phi1-pi)*cos(half*(theta1+theta_pi)) - part1 = (theta_pi - theta1)*(f1 +4*fm - fpi)/6.0 - - fm = half*(phi2+pi)*cos(half*(theta2+theta_pi)) - part2 = 0.5*(theta2 - theta_pi)*(fpi + 4*fm + f2)/6.0 - weights(num_wts+1) = part1 + part2 - - part1 = 0.5*(theta_pi - theta1)*(theta1*f1 - theta_pi*fpi) - part2 = 0.5*(theta2 - theta_pi)*(theta_pi*fpi + theta2*f2) - weights(num_wts+2) = part1 + part2 - - endif - - part1 = 0.25*(theta_pi - theta1)*(f1*f1 + fpi*fpi) - part2 = 0.25*(theta2 - theta_pi)*(fpi*fpi + f2*f2) - weights(num_wts+3) = part1 + part2 - - endif - -!----------------------------------------------------------------------- - - end subroutine line_integral_theta - -!*********************************************************************** - - - - subroutine store_link_cnsrv(add1, add2, weights) - -!----------------------------------------------------------------------- -! -! this routine stores the address and weight for this link in -! the appropriate address and weight arrays and resizes those -! arrays if necessary. -! -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -! -! input variables -! -!----------------------------------------------------------------------- - - integer (SCRIP_i4), intent(in) :: - & add1, ! address on grid1 - & add2 ! address on grid2 - - real (SCRIP_r8), dimension(:), intent(in) :: - & weights ! array of remapping weights for this link - -!----------------------------------------------------------------------- -! -! local variables -! -!----------------------------------------------------------------------- - - integer (SCRIP_i4) :: nlink, min_link, max_link ! link index - - logical (SCRIP_logical) :: found - - -!----------------------------------------------------------------------- -! -! if all weights are zero, do not bother storing the link -! -!----------------------------------------------------------------------- - - if (all(weights == zero)) return - -!----------------------------------------------------------------------- -! -! restrict the range of links to search for existing links -! -!----------------------------------------------------------------------- - -C$OMP CRITICAL(block5) -! first_call should be within critical block or else multiple -! threads will see it as true the first time around - - if (first_call_store_link_cnsrv) then - allocate(link_add1(2,grid1_size), link_add2(2,grid2_size)) - link_add1 = 0 - link_add2 = 0 - first_call_store_link_cnsrv = .false. - min_link = 1 - max_link = 0 - else - min_link = min(link_add1(1,add1),link_add2(1,add2)) - max_link = max(link_add1(2,add1),link_add2(2,add2)) - if (min_link == 0) then - min_link = 1 - max_link = 0 - endif - endif -C$OMP END CRITICAL(block5) - -!----------------------------------------------------------------------- -! -! if the link already exists, add the weight to the current weight -! arrays -! -!----------------------------------------------------------------------- - - found = .false. - - do nlink=min_link,max_link - if (add1 == grid1_add_map1(nlink)) then - if (add2 == grid2_add_map1(nlink)) then - -C$OMP CRITICAL(block3a) - wts_map1(:,nlink) = wts_map1(:,nlink) + weights(1:num_wts) - if (num_maps == 2) then - wts_map2(:,nlink) = wts_map2(:,nlink) + - & weights(num_wts+1:2*num_wts) - endif -C$OMP END CRITICAL(block3a) - found = .true. - exit - - endif - endif - end do - - - if (found) return - -!----------------------------------------------------------------------- -! -! if the link does not yet exist, increment number of links and -! check to see if remap arrays need to be increased to accomodate -! the new link. then store the link. -! -!----------------------------------------------------------------------- - -C$OMP CRITICAL(block6) - - num_links_map1 = num_links_map1 + 1 - if (num_links_map1 > max_links_map1) - & call resize_remap_vars(1,resize_increment) - - grid1_add_map1(num_links_map1) = add1 - grid2_add_map1(num_links_map1) = add2 - wts_map1 (:,num_links_map1) = weights(1:num_wts) - - if (num_maps > 1) then - num_links_map2 = num_links_map2 + 1 - if (num_links_map2 > max_links_map2) - & call resize_remap_vars(2,resize_increment) - - grid1_add_map2(num_links_map2) = add1 - grid2_add_map2(num_links_map2) = add2 - wts_map2 (:,num_links_map2) = weights(num_wts+1:2*num_wts) - endif - - if (link_add1(1,add1) == 0) link_add1(1,add1) = num_links_map1 - if (link_add2(1,add2) == 0) link_add2(1,add2) = num_links_map1 - link_add1(2,add1) = num_links_map1 - link_add2(2,add2) = num_links_map1 - -C$OMP END CRITICAL(block6) - -!----------------------------------------------------------------------- - - end subroutine store_link_cnsrv - -!*********************************************************************** - - - - - subroutine locate_segstart(cell_grid_num, cell, - & beglat, beglon, endlat, endlon, offset, - & srch_grid_num, cont_cell, lboundary, edgeid) - -!----------------------------------------------------------------------- -! -! Find the cell containing the given point -! -!----------------------------------------------------------------------- - - implicit none - -!----------------------------------------------------------------------- -! -! intent(in): -! -!----------------------------------------------------------------------- - - real (SCRIP_r8), intent(in) :: - & beglat, beglon, ! beginning and end points of segment - & endlat, endlon ! on which the point to be located lies - - real (SCRIP_r8), intent(in) :: - & offset ! Offset to calculate the search point - - integer (SCRIP_i4), intent(in) :: - & cell, ! Cell from which point originates - ! Point will be on boundary of orig_cell - & cell_grid_num ! Index of grid to which cell belongs - - integer (SCRIP_i4), intent(in) :: - & srch_grid_num ! num indicating if we are locating a - ! grid1 point in a cell of grid2 (num=2) - ! or a grid2 point in a cell of grid1 - ! (num=1) - -!----------------------------------------------------------------------- -! -! intent(out): -! -!----------------------------------------------------------------------- - - integer (SCRIP_i4), intent(out) :: - & cont_cell ! grid cell containing this point - - logical (SCRIP_logical), intent(out) :: - & lboundary ! flag points that lie on the boundary - ! of the cell - - integer (SCRIP_i4), intent(out) :: - & edgeid ! if point is on boundary, which local - ! edge is it on? (0 otherwise) - -!----------------------------------------------------------------------- -! -! local variables -! -!----------------------------------------------------------------------- - - integer (SCRIP_i4) :: i, j, k, n, ic - integer (SCRIP_i4) :: whichpole, srch_cell_add, - & grid1_add, grid2_add, min_add, max_add - - real (SCRIP_r8), dimension(:), allocatable :: - & cell_corner_x, cell_corner_y - - logical (SCRIP_logical) :: inpoly, latlon - - real (SCRIP_r8) :: - & vec1_x, vec1_y, vec1_lenx, vec1_lat, vec1_lon, vec1_len, - & begx, begy, endx, endy, ptx, pty, rns, pi4, ptlat, ptlon, - & lat, lon, cell_center_x, cell_center_y - -!----------------------------------------------------------------------- -! -! initialize defaults, flags, etc. -! -!----------------------------------------------------------------------- - - lboundary = .false. - edgeid = 0 - cont_cell = 0 - - - if (cell /= last_cell_locate_segstart .or. - & cell_grid_num /= last_cell_grid_num_locate_segstart - & .or. srch_grid_num /= last_srch_grid_num_locate_segstart) - & then - - last_cell_locate_segstart = cell - last_cell_grid_num_locate_segstart = cell_grid_num - last_srch_grid_num_locate_segstart = srch_grid_num - - if (first_call_locate_segstart) then - first_call_locate_segstart = .false. - last_cell_locate_segstart = 0 - last_cell_grid_num_locate_segstart = 0 - last_srch_grid_num_locate_segstart = 0 - num_srch_cells_locate_segstart = 0 - else - if (num_srch_cells_locate_segstart .gt. 0) then - deallocate(srch_add_locate_segstart, - & srch_corner_lat_locate_segstart, - & srch_corner_lon_locate_segstart, - & srch_center_lat_locate_segstart, - & srch_center_lon_locate_segstart) - endif - endif - - call get_srch_cells(cell, cell_grid_num, srch_grid_num, - & num_srch_cells_locate_segstart, srch_add_locate_segstart, - & srch_corners_locate_segstart, - & srch_corner_lat_locate_segstart, - & srch_corner_lon_locate_segstart, - & srch_center_lat_locate_segstart, - & srch_center_lon_locate_segstart) - - endif - - if (num_srch_cells_locate_segstart == 0) return - - - do ic=1,num_srch_cells_locate_segstart - - srch_cell_add = srch_add_locate_segstart(ic) - - - - !**** CAN WE ACCOMPLISH THE FOLLOWING THROUGH A SUBROUTINE - !**** CALLED SEGSTART_INCELL ?? - - - !*** IF POINT IS IN POLAR REGION, CHECK IN A TRANSFORMED SPACE - !*** HOWEVER, POINTS THAT ARE PRACTICALLY AT THE POLE CANNOT - !*** BE CORRECTLY LOCATED THIS WAY BECAUSE THE POLE IS A SINGULARITY - !*** AND CONTAINMENT IN ANY CELL INCIDENT ON THE POLE WILL GIVE US A - !*** POSITIVE ANSWER. FOR THESE POINTS REVERT TO THE LATLON SPACE - !*** - - - - vec1_lat = endlat-beglat - vec1_lon = endlon-beglon - if (vec1_lon > pi) then - vec1_lon = vec1_lon - pi2 - else if (vec1_lon < -pi) then - vec1_lon = vec1_lon + pi2 - endif - vec1_len = sqrt(vec1_lat*vec1_lat+vec1_lon*vec1_lon) - vec1_lat = vec1_lat/vec1_len - vec1_lon = vec1_lon/vec1_len - - ptlat = beglat + offset*vec1_lat - ptlon = beglon + offset*vec1_lon - - - if ((ptlat .gt. north_thresh .and. abs(ptlat-pih) .ge. 0.001) - & .or. - & (ptlat .lt. south_thresh .and. abs(ptlat+pih) .ge. 0.001)) - & then - - if (ptlat > zero) then - pi4 = quart*pi - rns = one - else - pi4 = -quart*pi - rns = -one - endif - - - begx = rns*two*sin(pi4 - half*beglat)*cos(beglon) - begy = two*sin(pi4 - half*beglat)*sin(beglon) - endx = rns*two*sin(pi4 - half*endlat)*cos(endlon) - endy = two*sin(pi4 - half*endlat)*sin(endlon) - - vec1_x = endx-begx - vec1_y = endy-begy - - vec1_lenx = sqrt(vec1_x*vec1_x + vec1_y*vec1_y) - vec1_x = vec1_x/vec1_lenx - vec1_y = vec1_y/vec1_lenx - - - !*** Must calculate ptx and pty as an offset on straight - !*** line in polar space rather than calculating it on a - !*** straight line in latlon space an offset point in latlon - !*** space will be off the straight line in polar space - - ptx = begx + offset*vec1_x - pty = begy + offset*vec1_y - - latlon = .false. - - ! Since we want greater fidelity for locating the points - ! we send in the mid-points of the polygon edges too - ! BUT THAT MAKES THE POLYGON NON-CONVEX SOMETIMES AND - ! THE CROSS-PRODUCT CHECK FAILS. SO USE CODE TO CHECK GENERAL - ! POLYGONS - - - allocate(cell_corner_x(npseg*srch_corners_locate_segstart), - & cell_corner_y(npseg*srch_corners_locate_segstart)) - - - k = 0 - do i = srch_corners_locate_segstart, 1, -1 - k = k+1 - lat = srch_corner_lat_locate_segstart(i,ic) - lon = srch_corner_lon_locate_segstart(i,ic) - cell_corner_x(k) = rns*two*sin(pi4-half*lat)*cos(lon) - cell_corner_y(k) = two*sin(pi4-half*lat)*sin(lon) - - j = i-1 - if (j .eq. 0) j = srch_corners_locate_segstart ! how do - ! we do (j-1+n)%n in F90? - - vec1_lat = srch_corner_lat_locate_segstart(j,ic) - & -srch_corner_lat_locate_segstart(i,ic) - vec1_lon = srch_corner_lon_locate_segstart(j,ic) - & -srch_corner_lon_locate_segstart(i,ic) - if (vec1_lon > pi) then - vec1_lon = vec1_lon - pi2 - else if (vec1_lon < -pi) then - vec1_lon = vec1_lon + pi2 - endif - - do j = 1, npseg-1 - k = k+1 - lat = srch_corner_lat_locate_segstart(i,ic) - & + j*vec1_lat/npseg - lon = srch_corner_lon_locate_segstart(i,ic) - & + j*vec1_lon/npseg - cell_corner_x(k) = rns*two*sin(pi4-half*lat)*cos(lon) - cell_corner_y(k) = two*sin(pi4-half*lat)*sin(lon) - enddo - enddo - - - call ptinpolygen2(ptx, pty, k, cell_corner_x, - & cell_corner_y, latlon, inpoly, lboundary, edgeid) - - if (lboundary) then - edgeid = (edgeid-1)/npseg + 1 ! convert from index in - ! multi-segmented to regular cell - endif - - deallocate(cell_corner_x, cell_corner_y) - - else - - latlon = .true. - - whichpole = 0 - if (srch_grid_num .eq. 1 .and. - & srch_cell_add .eq. grid1_spole_cell) then - - whichpole = -1 ! S pole - call ptinpolarpoly(ptlat, ptlon, - & srch_corners_locate_segstart, - & srch_corner_lat_locate_segstart(:,ic), - & srch_corner_lon_locate_segstart(:,ic), - & latlon, whichpole, inpoly, lboundary, edgeid) - - else if (srch_grid_num .eq. 1 .and. - & srch_cell_add .eq. grid1_npole_cell) then - - whichpole = 1 ! N pole - call ptinpolarpoly(ptlat, ptlon, - & srch_corners_locate_segstart, - & srch_corner_lat_locate_segstart(:,ic), - & srch_corner_lon_locate_segstart(:,ic), - & latlon, whichpole, inpoly, lboundary, edgeid) - - else if (srch_grid_num .eq. 2 .and. - & srch_cell_add .eq. grid2_spole_cell) then - - whichpole = -1 ! S pole - call ptinpolarpoly(ptlat, ptlon, - & srch_corners_locate_segstart, - & srch_corner_lat_locate_segstart(:,ic), - & srch_corner_lon_locate_segstart(:,ic), - & latlon, whichpole, inpoly, lboundary, edgeid) - - else if (srch_grid_num .eq. 2 .and. - & srch_cell_add .eq. grid2_npole_cell) then - - whichpole = 1 ! N pole - call ptinpolarpoly(ptlat, ptlon, - & srch_corners_locate_segstart, - & srch_corner_lat_locate_segstart(:,ic), - & srch_corner_lon_locate_segstart(:,ic), - & latlon, whichpole, inpoly, lboundary, edgeid) - - else - - !*** - !*** General cell - !*** - - call ptinpoly(ptlat, ptlon, srch_corners_locate_segstart, - & srch_corner_lat_locate_segstart(:,ic), - & srch_corner_lon_locate_segstart(:,ic), - & latlon, inpoly, lboundary, edgeid) - - endif - - endif - - if (inpoly) then - cont_cell = srch_cell_add - exit - endif - - end do - - return - -!---------------------------------------------------------------------- - - end subroutine locate_segstart - -!********************************************************************** - - - - -!********************************************************************** - - subroutine locate_point(ptlat, ptlon, cell, cell_grid_num, - & srch_grid_num, cont_cell, lboundary, edgeid) - -!----------------------------------------------------------------------- -! -! Find the cell containing the given point -! -!----------------------------------------------------------------------- - - implicit none - -!----------------------------------------------------------------------- -! -! intent(in): -! -!----------------------------------------------------------------------- - - real (SCRIP_r8), intent(in) :: - & ptlat, ptlon ! Point to locate - - integer (SCRIP_i4), intent(in) :: - & cell, ! Cell from which point originates - ! Point will be on boundary of orig_cell - & cell_grid_num ! Index of grid to which cell belongs - - integer (SCRIP_i4), intent(in) :: - & srch_grid_num ! num indicating if we are locating a - ! grid1 point in a cell of grid2 (num=2) - ! or a grid2 point in a cell of grid1 - ! (num=1) - -!----------------------------------------------------------------------- -! -! intent(out): -! -!----------------------------------------------------------------------- - - integer (SCRIP_i4), intent(out) :: - & cont_cell ! grid cell containing this point - - logical (SCRIP_logical), intent(out) :: - & lboundary ! flag points that lie on the boundary - ! of the cell - - integer (SCRIP_i4), intent(out) :: - & edgeid ! if point is on boundary, which local - ! edge is it on? (0 otherwise) - -!----------------------------------------------------------------------- -! -! local variables -! -!----------------------------------------------------------------------- - - integer (SCRIP_i4) :: i, j, n, ic - integer (SCRIP_i4) :: whichpole, srch_cell_add, - & grid1_add, grid2_add, min_add, max_add, - & previdx, nextidx, pcorner, corner, - & ncorners, nalloc - - real (SCRIP_r8), dimension(:), allocatable :: - & cell_corner_lat, - & cell_corner_lon - - real (SCRIP_r8) :: - & prevlon, - & nextlon, - & polelat, - & cell_center_lat, - & cell_center_lon - - - logical (SCRIP_logical) :: inpoly, latlon - logical (SCRIP_logical) :: test - -!----------------------------------------------------------------------- -! -! initialize defaults, flags, etc. -! -!----------------------------------------------------------------------- - - lboundary = .false. - edgeid = 0 - cont_cell = 0 - - if (cell /= last_cell_locate_point .or. cell_grid_num /= - & last_cell_grid_num_locate_point - & .or. srch_grid_num /= last_srch_grid_num_locate_point) then - - last_cell_locate_point = cell - last_cell_grid_num_locate_point = cell_grid_num - last_srch_grid_num_locate_point = srch_grid_num - - if (first_call_locate_point) then - first_call_locate_point = .false. - last_cell_locate_point = 0 - last_cell_grid_num_locate_point = 0 - last_srch_grid_num_locate_point = 0 - num_srch_cell_locate_points = 0 - else - if (num_srch_cell_locate_points .gt. 0) then - deallocate(srch_add_locate_point, - & srch_corner_lat_locate_point, - & srch_corner_lon_locate_point) - endif - endif - - call get_srch_cells(cell, cell_grid_num, srch_grid_num, - & num_srch_cell_locate_points, srch_add_locate_point, - & srch_corners_locate_point, - & srch_corner_lat_locate_point,srch_corner_lon_locate_point, - & srch_center_lat_locate_point,srch_center_lon_locate_point) - - endif - - if (num_srch_cell_locate_points == 0) return - - - ncorners = srch_corners_locate_point - nalloc = ncorners+2 - allocate(cell_corner_lat(nalloc), - & cell_corner_lon(nalloc)) - - - do ic=1,num_srch_cell_locate_points - - srch_cell_add = srch_add_locate_point(ic) - - do i = 1, ncorners - cell_corner_lat(i) = srch_corner_lat_locate_point(i,ic) - cell_corner_lon(i) = srch_corner_lon_locate_point(i,ic) - enddo - - cell_center_lat = srch_center_lat_locate_point(ic) - cell_center_lon = srch_center_lon_locate_point(ic) - -! if ((srch_grid_num .eq. 1 .and. -! & (special_polar_cell1(srch_cell_add))) .or. -! & (srch_grid_num .eq. 2 .and. -! & (special_polar_cell2(srch_cell_add)))) then -! -! Modified by MD - test=.false. - if (srch_grid_num .eq. 1) then - if (special_polar_cell1(srch_cell_add)) then - test=.true. - endif - else - if (special_polar_cell2(srch_cell_add)) then - test=.true. - endif - endif - if (test) then - call modify_polar_cell(ncorners, nalloc, cell_corner_lat, - & cell_corner_lon) - - endif - - call ptincell(ptlat, ptlon, srch_cell_add, ncorners, - & cell_corner_lat, cell_corner_lon, - & cell_center_lat, cell_center_lon, - & srch_grid_num, inpoly, lboundary, edgeid) - - - if (inpoly) then - cont_cell = srch_cell_add - exit - endif - - ncorners = srch_corners_locate_point ! reset it for other srch - !cells - end do - -!---------------------------------------------------------------------- - - end subroutine locate_point - -!********************************************************************** - - - -!********************************************************************** - - subroutine ptincell(ptlat, ptlon, cell_add, ncorners, - & cell_corner_lat, cell_corner_lon, - & cell_center_lat, cell_center_lon, - & cell_grid_id, inpoly, lboundary, edgeid) - -!---------------------------------------------------------------------- - - implicit none - -!----------------------------------------------------------------------- -! -! intent(in): -! -!----------------------------------------------------------------------- - - real (SCRIP_r8), intent(in) :: - & ptlat, ptlon ! Point to locate - - integer (SCRIP_i4), intent(in) :: - & cell_add ! ID of cell - - integer (SCRIP_i4), intent(in) :: - & ncorners - - real (SCRIP_r8), dimension(ncorners), intent(in) :: - & cell_corner_lat, cell_corner_lon - - real (SCRIP_r8), intent(in) :: - & cell_center_lat, - & cell_center_lon - - integer (SCRIP_i4), intent(in) :: - & cell_grid_id ! num indicating if we are locating a grid1 - ! point in a cell of grid2 (num = 2) or - ! a grid2 point in a cell of grid1 (num = 1) - - -!----------------------------------------------------------------------- -! -! intent(out): -! -!----------------------------------------------------------------------- - - logical (SCRIP_logical), intent(out) :: - & inpoly ! is point in polygon? - - logical (SCRIP_logical), intent(out) :: - & lboundary ! flag points that lie on the boundary - ! of the cell - - integer (SCRIP_i4), intent(out) :: - & edgeid ! if point is on boundary, which local - ! edge is it on? (0 otherwise) -!----------------------------------------------------------------------- -! -! local variables -! -!----------------------------------------------------------------------- - - integer (SCRIP_i4) :: i, j, k, ic - integer (SCRIP_i4) :: whichpole - - real (SCRIP_r8) :: rns, pi4, ptx, pty, lat, lon, - & cell_center_x, cell_center_y, vec1_lat, vec1_lon - - logical (SCRIP_logical) :: - & latlon - - real (kind=SCRIP_r8), dimension(npseg*ncorners) :: - & cell_corner_x, ! x of each corner of cell - & cell_corner_y ! y of each corner of cell - -!---------------------------------------------------------------------- - - edgeid = 0 - - - !*** IF POINTS ARE ABOVE THE THRESHOLD, CHECK THEM IN A TRANSFORMED - !*** SPACE - !*** HOWEVER, POINTS THAT ARE PRACTICALLY AT THE POLE CANNOT - !*** BE CORRECTLY LOCATED THIS WAY BECAUSE THE POLE IS A SINGULARITY - !*** AND CONTAINMENT IN ANY CELL INCIDENT ON THE POLE WILL GIVE US A - !*** POSITIVE ANSWER. FOR THESE POINTS REVERT TO THE LATLON SPACE - !*** - - if ((ptlat .gt. north_thresh .and. abs(ptlat-pih) .ge. 0.001) .or. - & (ptlat .lt. south_thresh .and. abs(ptlat+pih) .ge. 0.001)) - & then - - if (ptlat > zero) then - pi4 = quart*pi - rns = one - else - pi4 = -quart*pi - rns = -one - endif - - ptx = rns*two*sin(pi4 - half*ptlat)*cos(ptlon) - pty = two*sin(pi4 - half*ptlat)*sin(ptlon) - - latlon = .false. - - ! Since we want greater fidelity for locating the points - ! we send in the mid-points of the polygon edges too - ! BUT THAT MAKES THE POLYGON NON-CONVEX SOMETIMES AND - ! THE CROSS-PRODUCT CHECK FAILS. SO USE CODE TO CHECK GENERAL - ! POLYGONS - - - k = 0 - do i = ncorners, 1, -1 - k = k+1 - lat = cell_corner_lat(i) - lon = cell_corner_lon(i) - cell_corner_x(k) = rns*two*sin(pi4-half*lat)*cos(lon) - cell_corner_y(k) = two*sin(pi4-half*lat)*sin(lon) - - j = i-1 - if (j .eq. 0) j = ncorners ! how do we do (j-1+n)%n in F90? - - vec1_lat = cell_corner_lat(j)-cell_corner_lat(i) - vec1_lon = cell_corner_lon(j)-cell_corner_lon(i) - if (vec1_lon > pi) then - vec1_lon = vec1_lon - pi2 - else if (vec1_lon < -pi) then - vec1_lon = vec1_lon + pi2 - endif - - do j = 1, npseg-1 - k = k+1 - lat = cell_corner_lat(i) + j*vec1_lat/npseg - lon = cell_corner_lon(i) + j*vec1_lon/npseg - cell_corner_x(k) = rns*two*sin(pi4-half*lat)*cos(lon) - cell_corner_y(k) = two*sin(pi4-half*lat)*sin(lon) - enddo - enddo - - !*** cell is so non-convex that no feasible center exists - !*** we have to fall back on a different algorithm - - call ptinpolygen2(ptx, pty, k, cell_corner_x, - & cell_corner_y, latlon, inpoly, lboundary, edgeid) - - if (lboundary) then - edgeid = (edgeid-1)/npseg + 1 ! convert from index in - ! multi-segmented cell to - ! regular cell - endif - else - - latlon = .true. - - whichpole = 0 - if (cell_grid_id .eq. 1 .and. - & cell_add .eq. grid1_spole_cell) then - - whichpole = -1 ! S pole - call ptinpolarpoly(ptlat, ptlon, ncorners, - & cell_corner_lat, cell_corner_lon, - & latlon, whichpole, inpoly, lboundary, edgeid) - - else if (cell_grid_id .eq. 1 .and. - & cell_add .eq. grid1_npole_cell) then - - whichpole = 1 ! N pole - call ptinpolarpoly(ptlat, ptlon, ncorners, - & cell_corner_lat, cell_corner_lon, - & latlon, whichpole, inpoly, lboundary, edgeid) - - else if (cell_grid_id .eq. 2 .and. - & cell_add .eq. grid2_spole_cell) then - - whichpole = -1 ! S pole - call ptinpolarpoly(ptlat, ptlon, ncorners, - & cell_corner_lat, cell_corner_lon, - & latlon, whichpole, inpoly, lboundary, edgeid) - - else if (cell_grid_id .eq. 2 .and. - & cell_add .eq. grid2_npole_cell) then - - whichpole = 1 ! N pole - call ptinpolarpoly(ptlat, ptlon, ncorners, - & cell_corner_lat, cell_corner_lon, - & latlon, whichpole, inpoly, lboundary, edgeid) - - else - - !*** - !*** General cell - !*** - - call ptinpoly(ptlat, ptlon, ncorners, - & cell_corner_lat, cell_corner_lon, - & latlon, inpoly, lboundary, edgeid) - - endif - - endif - - return - -!---------------------------------------------------------------------- - - end subroutine ptincell - -!********************************************************************** - -!********************************************************************** - - subroutine ptinpoly(ptx, pty, ncorners, cell_corner_x, - & cell_corner_y, latlon, inpoly, lboundary, edgeid) - -!---------------------------------------------------------------------- -! -! Check if point is in (convex) polygonal cell -! -!---------------------------------------------------------------------- - - implicit none - -!---------------------------------------------------------------------- -! -! Input arguments -! -!---------------------------------------------------------------------- - - real (SCRIP_r8), intent(in) :: - & ptx, pty ! Point to check - - integer (SCRIP_i4), intent(in) :: - & ncorners ! Number of polygon corners - - real (SCRIP_r8), dimension(ncorners), intent(in) :: - & cell_corner_x, ! Coordinates of cell corners - & cell_corner_y ! Could be x-y or lat-lon or ... - - logical (SCRIP_logical), intent(in) :: - & latlon ! Are coordinates in latlon space? - -!---------------------------------------------------------------------- -! -! Output arguments -! -!---------------------------------------------------------------------- - - logical (SCRIP_logical), intent(out) :: - & inpoly ! Is point in the polygon? - - logical (SCRIP_logical), intent(out) :: - & lboundary ! Is point on the boundary of the polygon? - - integer (SCRIP_i4), intent(out) :: - & edgeid ! if point is on boundary, which local - ! edge is it on? (0 otherwise) - -!---------------------------------------------------------------------- -! -! Local variables -! -!---------------------------------------------------------------------- - - integer (SCRIP_i4) :: n, next_n - - real (SCRIP_r8) :: x1, y1, x2, y2, vec1_x, vec1_y, vec2_x, vec2_y, - & cross_product, minlon, maxlon, ptx_loc, pty_loc - - real (SCRIP_r8), dimension(ncorners) :: - & cell_corner_lat_loc, cell_corner_lon_loc - - - !*********************************************************** - !*** We should just remove the latlon argument since that is - !*** the only coordinate system we are using it for - !*********************************************************** - - - !*** - !*** here we take the cross product of the vector making - !*** up each cell side with the vector formed by the vertex - !*** and search point. if all the cross products are - !*** positive, the point is contained in the cell. - !*** - - inpoly = .false. - lboundary = .false. - edgeid = 0 - - if (.not. latlon) then - - do n = 1, ncorners - next_n = MOD(n,ncorners) + 1 - - x1 = cell_corner_x(n) - y1 = cell_corner_y(n) - x2 = cell_corner_x(next_n) - y2 = cell_corner_y(next_n) - - vec1_x = x2 - x1 - vec1_y = y2 - y1 - vec2_x = ptx - x1 - vec2_y = pty - y1 - - cross_product = vec1_y*vec2_x - vec2_y*vec1_x - - !*** - !*** if the cross product for a side is zero, the point - !*** lies exactly on the side or the side is degenerate - !*** (zero length). if degenerate, set the cross - !*** product to a positive number. - !*** - - if (abs(cross_product) < tiny) then - if (vec1_x*vec1_x + vec1_y*vec1_y .le. tiny*tiny) then - cross_product = one - else - lboundary = .true. - edgeid = n - endif - else - - !*** - !*** if cross product is less than zero, this cell - !*** doesn't work - !*** - !*** Should we say "if (cp < zero .and. abs(cp) > tiny)" ? - - if (cross_product < zero) then - inpoly = .false. - lboundary = .false. - return - endif - endif - - end do - - else - - !*** Checking in latlon space - !*** If the grid cell coordinates spans more than pi radians - !*** transform the coordinates so that they don't - - cell_corner_lat_loc = cell_corner_x - cell_corner_lon_loc = cell_corner_y - - minlon = 9999.0 - maxlon = -9999.0 - do n = 1, ncorners - if (cell_corner_lon_loc(n) < minlon) then - minlon = cell_corner_lon_loc(n) - endif - if (cell_corner_lon_loc(n) > maxlon) then - maxlon = cell_corner_lon_loc(n) - endif - enddo - - if (maxlon-minlon > pi) then - - do n = 1, ncorners - if (cell_corner_lon_loc(n)-minlon > pi) then - cell_corner_lon_loc(n) = cell_corner_lon_loc(n)-pi2 - endif - enddo - - endif - - ptx_loc = ptx - pty_loc = pty - if (pty_loc - minlon > pi) then - pty_loc = pty_loc - pi2 - else if (pty_loc - minlon < -pi) then - pty_loc = pty_loc + pi2 - endif - - - do n = 1, ncorners - next_n = MOD(n,ncorners) + 1 - - x1 = cell_corner_lat_loc(n) - y1 = cell_corner_lon_loc(n) - x2 = cell_corner_lat_loc(next_n) - y2 = cell_corner_lon_loc(next_n) - - vec1_x = x2 - x1 - vec1_y = y2 - y1 - vec2_x = ptx_loc - x1 - vec2_y = pty_loc - y1 - - cross_product = vec1_y*vec2_x - vec2_y*vec1_x - - !*** - !*** if the cross product for a side is zero, the point - !*** lies exactly on the side or the side is degenerate - !*** (zero length). if degenerate, set the cross - !*** product to a positive number. - !*** - - if (abs(cross_product) < tiny) then - if (vec1_x*vec1_x + vec1_y*vec1_y .le. tiny*tiny) then - cross_product = one - else - lboundary = .true. - edgeid = n - endif - else - - !*** - !*** if cross product is less than zero, this cell - !*** doesn't work - !*** - !*** Should we say "if (cp < zero .and. abs(cp) > tiny)" ? - - if (cross_product < zero) then - inpoly = .false. - lboundary = .false. - return - endif - endif - - end do - - endif - !*** - !*** if cross products all positive, we found the location - !*** - - inpoly = .true. - return - -!---------------------------------------------------------------------- - - end subroutine ptinpoly - -!********************************************************************** - - - - subroutine ptinpolarpoly(ptx, pty, ncorners, cell_corner_x, - & cell_corner_y, latlon, whichpole, inpoly, lboundary, edgeid) - -!---------------------------------------------------------------------- -! -! Check if point is in polygonal cell overlapping the pole -! Cannot check the containment as is in latlon space - We have -! to check by connecting each edge of the polygon to the pole -! and check containment in the resulting quadrilateral in latlon -! space -! The cell can be non-convex as long as the pole is 'visible' to -! all the edges of the polygon, i.e., we can connect the pole to -! each edge of the polygon and form a triangle with positive area -! -!---------------------------------------------------------------------- - - implicit none - -!---------------------------------------------------------------------- -! -! Input arguments -! -!---------------------------------------------------------------------- - - real (SCRIP_r8), intent(in) :: - & ptx, pty ! Point to check - - integer (SCRIP_i4), intent(in) :: - & ncorners ! Number of polygon corners - - real (SCRIP_r8), dimension(ncorners), intent(in) :: - & cell_corner_x, ! Coordinates of cell corners - & cell_corner_y ! Could be x-y or lat-lon or ... - - logical (SCRIP_logical), intent(in) :: - & latlon ! Are coordinates in latlon space? - - integer (SCRIP_i4), intent(in) :: - & whichpole ! South or North pole - -!---------------------------------------------------------------------- -! -! Output arguments -! -!---------------------------------------------------------------------- - - logical (SCRIP_logical), intent(out) :: - & inpoly ! Is point in the polygon? - - logical (SCRIP_logical), intent(out) :: - & lboundary ! Is point on the boundary of the polygon? - - integer (SCRIP_i4), intent(out) :: - & edgeid ! if point is on boundary, which local - ! edge is it on? (0 otherwise) - -!---------------------------------------------------------------------- -! -! Local variables -! -!---------------------------------------------------------------------- - - integer (SCRIP_i4) :: n, next_n, ledgeid - - real (SCRIP_r8), dimension(4) :: - & pquad_corner_x, ! Coordinates of polar quad - & pquad_corner_y - - real (SCRIP_r8) :: x1, y1, x2, y2, vec1_x, vec1_y, vec2_x, vec2_y, - & cross_product, pole_lat - - pole_lat = whichpole*pih - - !*** - !*** This is a polygon that overlaps the pole - !*** A normal point in polygon check could fail - !*** So, with each edge of the polygon form a quadrilateral - !*** in latlon space using the polar latitude and the longitude - !*** values of the endpoints of the edge. Then check containment - !*** of the point in this quadrilateral - !*** - - inpoly = .false. - lboundary = .false. - - do n = 1, ncorners - next_n = MOD(n,ncorners) + 1 - - pquad_corner_x(1) = cell_corner_x(n) - pquad_corner_y(1) = cell_corner_y(n) - pquad_corner_x(2) = cell_corner_x(next_n) - pquad_corner_y(2) = cell_corner_y(next_n) - pquad_corner_x(3) = pole_lat - pquad_corner_y(3) = cell_corner_y(next_n) - pquad_corner_x(4) = pole_lat - pquad_corner_y(4) = cell_corner_y(n) - - - call ptinpoly(ptx,pty,4,pquad_corner_x,pquad_corner_y, - & latlon,inpoly,lboundary, ledgeid) - - if (inpoly) then - - if (lboundary) then - - !*** - !*** Check to see if the lboundary flag is being - !*** triggered by the outer edge of the polygon or - !*** by one of the artificial internal edges - !*** - - vec1_x = pquad_corner_x(2) - pquad_corner_x(1) - vec1_y = pquad_corner_y(2) - pquad_corner_y(1) - vec2_x = ptx - pquad_corner_x(1) - vec2_y = pty - pquad_corner_y(1) - - - if (latlon) then - - !*** - !*** check for 0,2pi crossings - !*** - - if (vec1_y > pi) vec1_y = vec1_y - pi2 - if (vec1_y < -pi) vec1_y = vec1_y + pi2 - if (vec2_y > pi) vec2_y = vec2_y - pi2 - if (vec2_y < -pi) vec2_y = vec2_y + pi2 - - endif - - cross_product = vec1_y*vec2_x - vec2_y*vec1_x - - !*** - !*** if the cross product for a side is zero, the point - !*** lies exactly on the side or the side is degenerate - !*** (zero length). if degenerate, set the cross - !*** product to a positive number. - !*** - - if (abs(cross_product) < tiny) then - if (vec1_x .eq. zero .and. vec1_y .eq. zero) then - cross_product = one - lboundary = .false. - else - edgeid = n - lboundary = .true. - endif - else - lboundary = .false. - endif - endif ! if (lboundary) - - return ! pt in polygon - - endif ! if (inpoly) - - end do - - return ! pt outside polygon - -!---------------------------------------------------------------------- - - end subroutine ptinpolarpoly - -!********************************************************************** - - - - subroutine ptinpolygen(ptx, pty, ncorners, cell_corner_x, - & cell_corner_y, cell_center_x, cell_center_y, - & latlon, inpoly, lboundary, edgeid) - -!---------------------------------------------------------------------- -! -! Check if point is in general (convex or mildly non-convex) -! polygonal cell by connecting each edge of the polygon to a -! a central point (average of vertices) and check containment in -! the resulting triangle -! -! The cell can be non-convex as long as the 'center' is 'visible' to -! all the edges of the polygon, i.e., we can connect the 'center' to -! each edge of the polygon and form a triangle with positive area -! -!---------------------------------------------------------------------- - - implicit none - -!---------------------------------------------------------------------- -! -! Input arguments -! -!---------------------------------------------------------------------- - - real (SCRIP_r8), intent(in) :: - & ptx, pty ! Point to check - - integer (SCRIP_i4), intent(in) :: - & ncorners ! Number of polygon corners - - real (SCRIP_r8), dimension(ncorners), intent(in) :: - & cell_corner_x, ! Coordinates of cell corners - & cell_corner_y ! Could be x-y or lat-lon or ... - - real (SCRIP_r8), intent(in) :: - & cell_center_x, - & cell_center_y - - logical (SCRIP_logical), intent(in) :: - & latlon ! Are coordinates in latlon space? - -!---------------------------------------------------------------------- -! -! Output arguments -! -!---------------------------------------------------------------------- - - logical (SCRIP_logical), intent(out) :: - & inpoly ! Is point in the polygon? - - logical (SCRIP_logical), intent(out) :: - & lboundary ! Is point on the boundary of the polygon? - - integer (SCRIP_i4), intent(out) :: - & edgeid ! if point is on boundary, which local - ! edge is it on? (0 otherwise) - -!---------------------------------------------------------------------- -! -! Local variables -! -!---------------------------------------------------------------------- - - integer (SCRIP_i4) :: n, next_n, ledgeid - - real (SCRIP_r8), dimension(3) :: - & tri_corner_x, ! Coordinates of triangle - & tri_corner_y - - real (SCRIP_r8) :: x1, y1, x2, y2, vec1_x, vec1_y, vec2_x, vec2_y, - & cross_product - - - !*** - !*** So, with each edge of the polygon form a triangle - !*** by connecting a 'central' point to the endpoints of - !*** the edge. Then check containment of the point in this tri - !*** - - inpoly = .false. - lboundary = .false. - - do n = 1, ncorners - next_n = MOD(n,ncorners) + 1 - - tri_corner_x(1) = cell_corner_x(n) - tri_corner_y(1) = cell_corner_y(n) - tri_corner_x(2) = cell_corner_x(next_n) - tri_corner_y(2) = cell_corner_y(next_n) - tri_corner_x(3) = cell_center_x - tri_corner_y(3) = cell_center_y - - vec1_x = tri_corner_x(2) - tri_corner_x(1) - vec1_y = tri_corner_y(2) - tri_corner_y(1) - - !*** Skip triangles arising from degenerate edges - - if (vec1_x*vec1_x+vec1_y*vec1_y .le. tiny*tiny) cycle - - call ptinpoly(ptx,pty,3,tri_corner_x,tri_corner_y, - & latlon,inpoly,lboundary, ledgeid) - - if (inpoly) then - - if (lboundary) then - - !*** - !*** Check to see if the lboundary flag is being - !*** triggered by the outer edge of the polygon or - !*** by one of the artificial internal edges - !*** - - vec2_x = ptx - tri_corner_x(1) - vec2_y = pty - tri_corner_y(1) - - - if (latlon) then - - !*** - !*** check for 0,2pi crossings - !*** - - if (vec1_y > pi) vec1_y = vec1_y - pi2 - if (vec1_y < -pi) vec1_y = vec1_y + pi2 - if (vec2_y > pi) vec2_y = vec2_y - pi2 - if (vec2_y < -pi) vec2_y = vec2_y + pi2 - - endif - - cross_product = vec1_y*vec2_x - vec2_y*vec1_x - - !*** - !*** if the cross product for a side is zero, the point - !*** lies exactly on the side or the side is degenerate - !*** (zero length). if degenerate, set the cross - !*** product to a positive number. - !*** - - if (abs(cross_product) < tiny) then - if (vec1_x*vec1_x+vec1_y*vec1_y .le. tiny*tiny) then - cross_product = one - lboundary = .false. - else - edgeid = n - lboundary = .true. - endif - else - lboundary = .false. - endif - endif ! if (lboundary) - - return ! pt in polygon - - endif ! if (inpoly) - - end do - - return ! pt outside polygon - -!---------------------------------------------------------------------- - - end subroutine ptinpolygen - -!********************************************************************** - - - - subroutine ptinpolygen2(ptx, pty, ncorners, cell_corner_x, - & cell_corner_y, latlon, inpoly, lboundary, edgeid) - -!---------------------------------------------------------------------- -! -! Check if point is in general (convex or mildly non-convex) -! polygonal cell by connecting each edge of the polygon to a -! a central point (average of vertices) and check containment in -! the resulting triangle -! -! The cell can be non-convex as long as the 'center' is 'visible' to -! all the edges of the polygon, i.e., we can connect the 'center' to -! each edge of the polygon and form a triangle with positive area -! -!---------------------------------------------------------------------- - - implicit none - -!---------------------------------------------------------------------- -! -! Input arguments -! -!---------------------------------------------------------------------- - - real (SCRIP_r8), intent(in) :: - & ptx, pty ! Point to check - - integer (SCRIP_i4), intent(in) :: - & ncorners ! Number of polygon corners - - real (SCRIP_r8), dimension(ncorners), intent(in) :: - & cell_corner_x, ! Coordinates of cell corners - & cell_corner_y ! Could be x-y or lat-lon or ... - - logical (SCRIP_logical), intent(in) :: - & latlon ! Are coordinates in latlon space? - -!---------------------------------------------------------------------- -! -! Output arguments -! -!---------------------------------------------------------------------- - - logical (SCRIP_logical), intent(out) :: - & inpoly ! Is point in the polygon? - - logical (SCRIP_logical), intent(out) :: - & lboundary ! Is point on the boundary of the polygon? - - integer (SCRIP_i4), intent(out) :: - & edgeid ! if point is on boundary, which local - ! edge is it on? (0 otherwise) - -!---------------------------------------------------------------------- -! -! Local variables -! -!---------------------------------------------------------------------- - - integer (SCRIP_i4) :: c, n, next_n - - real (SCRIP_r8) :: x1, y1, x2, y2, vec1_x, vec1_y, vec2_x, vec2_y, - & vec3_x, vec3_y, vec1_len, vec2_len, vec3_len, - & cross_product, dot_product - - - !*** - !*** So, with each edge of the polygon form a triangle - !*** by connecting a 'central' point to the endpoints of - !*** the edge. Then check containment of the point in this tri - !*** - - inpoly = .false. - lboundary = .false. - - c = 0 - do n = 1, ncorners - next_n = MOD(n,ncorners) + 1 - - x1 = cell_corner_x(n) - y1 = cell_corner_y(n) - x2 = cell_corner_x(next_n) - y2 = cell_corner_y(next_n) - - if (((y1 > pty .and. y2 <= pty) .or. - & (y2 > pty .and. y1 <= pty)) .and. - & (ptx <= (x1 + (pty-y1)*(x2-x1)/(y2-y1)))) then - - c = 1 - c - - endif - enddo - - if (c .eq. 1) inpoly = .true. - - - !*** Check if the point is on the boundary of the polygon - - do n = 1, ncorners - - next_n = MOD(n,ncorners) + 1 - - x1 = cell_corner_x(n) - y1 = cell_corner_y(n) - x2 = cell_corner_x(next_n) - y2 = cell_corner_y(next_n) - - vec1_x = x2 - x1 - vec1_y = y2 - y1 - vec1_len = sqrt(vec1_x*vec1_x + vec1_y*vec1_y) - vec1_x = vec1_x/vec1_len - vec1_y = vec1_y/vec1_len - - vec2_x = ptx - x1 - vec2_y = pty - y1 - vec2_len = sqrt(vec2_x*vec2_x + vec2_y*vec2_y) - - cross_product = vec1_x*vec2_y - vec2_x*vec1_y - if (abs(cross_product) > tiny .and. vec2_len > tiny) then - cross_product = cross_product/vec2_len - endif - - if (abs(cross_product) < 1e5*tiny .and. - & abs(cross_product) > 10*tiny) then - - !*** Sometimes when the point is too close to a vertex - !*** then the cross product computation has errors due - !*** to subtraction of two small numbers - So check w.r.t. - !*** other vertex of the segment as well - - vec3_x = ptx - x2 - vec3_y = pty - y2 - vec3_len = sqrt(vec3_x*vec3_x + vec3_y*vec3_y) - - cross_product = -vec1_x*vec3_y + vec1_y*vec3_x - if (abs(cross_product) > tiny .and. vec3_len > tiny) then - !*** - !*** Normalize only if we won't be dividing two small - !*** numbers - cross_product = cross_product/vec3_len - endif - endif - - if (abs(cross_product) < 10*tiny) then - - if (vec1_x*vec1_x+vec1_y*vec1_y .le. tiny*tiny) then - cross_product = one - else - dot_product = vec1_x*vec2_x + vec1_y*vec2_y - - if (dot_product >= 0 .and. dot_product <= vec1_len) then - inpoly = .true. - lboundary = .true. - edgeid = n - exit - endif - endif - endif - - enddo - - return - -!---------------------------------------------------------------------- - - end subroutine ptinpolygen2 - -!********************************************************************** - - - - - -!---------------------------------------------------------------------- -! -!---------------------------------------------------------------------- - - subroutine get_srch_cells(cell_add, cell_grid_num, srch_grid_num, - & num_srch_cells, srch_add, srch_corners, - & srch_corner_lat, srch_corner_lon, - & srch_center_lat, srch_center_lon) - -!---------------------------------------------------------------------- -! -! Input arguments -! -!---------------------------------------------------------------------- - - integer (SCRIP_i4), intent(in) :: - & cell_add, ! cell in whose nbrhood we must find other - & cell_grid_num, ! cells grid number from which 'cell_add' - & srch_grid_num ! is grid number in which we must find - ! search cells - -!---------------------------------------------------------------------- -! -! Output arguments -! -!---------------------------------------------------------------------- - - integer (SCRIP_i4), intent(out) :: - & num_srch_cells, - & srch_corners ! Number of corners for search cells - - integer (SCRIP_i4), dimension(:), allocatable, intent(out) :: - & srch_add ! Global addresses of search cells - - real (SCRIP_r8), dimension(:,:), allocatable, intent(out) :: - & srch_corner_lat, srch_corner_lon - - real (SCRIP_r8), dimension(:), allocatable, intent(out) :: - & srch_center_lat, srch_center_lon - - -!----------------------------------------------------------------------- -! -! Local arguments -! -!----------------------------------------------------------------------- - - logical (SCRIP_logical), dimension(:), allocatable :: - & srch_mask - - integer (SCRIP_i4) :: grid1_add, grid2_add, max_add, min_add, - & n - -!----------------------------------------------------------------------- - - num_srch_cells = 0 - - !*** - !*** restrict searches first using search bins - !*** - - if (last_cell_add_get_srch_cells /= cell_add .or. - & last_cell_grid_num_get_srch_cells /= cell_grid_num .or. - & last_srch_grid_num_get_srch_cells /= srch_grid_num) then - - if (first_call_get_srch_cells) then - first_call_get_srch_cells = .false. - num_srch_cells_loc_get_srch_cells = 0 - srch_corners_loc_get_srch_cells = 0 - last_cell_add_get_srch_cells = 0 - last_cell_grid_num_get_srch_cells = 0 - last_srch_grid_num_get_srch_cells = 0 - else - if (num_srch_cells_loc_get_srch_cells .gt. 0) then - deallocate(srch_add_loc_get_srch_cells, - & srch_corner_lat_loc_get_srch_cells, - & srch_corner_lon_loc_get_srch_cells, - & srch_center_lat_loc_get_srch_cells, - & srch_center_lon_loc_get_srch_cells) - endif - - endif - - - last_cell_add_get_srch_cells = cell_add - last_cell_grid_num_get_srch_cells = cell_grid_num - last_srch_grid_num_get_srch_cells = srch_grid_num - - - if (cell_grid_num == 1) then - - if (srch_grid_num == 1) then - - !*** Grid 1 neighbors of grid 1 cell - - allocate(srch_mask(grid1_size)) - - min_add = grid1_size - max_add = 1 - do n=1,num_srch_bins - if (cell_add >= bin_addr1(1,n) .and. - & cell_add <= bin_addr1(2,n)) then - min_add = min(min_add, bin_addr1(1,n)) - max_add = max(max_add, bin_addr1(2,n)) - endif - end do - - !*** - !*** further restrict searches using bounding boxes - !*** - - num_srch_cells_loc_get_srch_cells = 0 - do grid1_add = min_add,max_add - srch_mask(grid1_add) = - & (grid1_bound_box(1,grid1_add) <= - & grid1_bound_box(2,cell_add)) .and. - & (grid1_bound_box(2,grid1_add) >= - & grid1_bound_box(1,cell_add)) .and. - & (grid1_bound_box(3,grid1_add) <= - & grid1_bound_box(4,cell_add)) .and. - & (grid1_bound_box(4,grid1_add) >= - & grid1_bound_box(3,cell_add)) - - if (srch_mask(grid1_add)) - & num_srch_cells_loc_get_srch_cells = - & num_srch_cells_loc_get_srch_cells+1 - end do - - if (num_srch_cells_loc_get_srch_cells /= 0) then - - !*** - !*** create search arrays - !*** - - allocate(srch_add_loc_get_srch_cells - & (num_srch_cells_loc_get_srch_cells), - & srch_corner_lat_loc_get_srch_cells - & (grid1_corners,num_srch_cells_loc_get_srch_cells), - & srch_corner_lon_loc_get_srch_cells - & (grid1_corners,num_srch_cells_loc_get_srch_cells), - & srch_center_lat_loc_get_srch_cells - & (num_srch_cells_loc_get_srch_cells), - & srch_center_lon_loc_get_srch_cells - & (num_srch_cells_loc_get_srch_cells)) - - n = 0 - do grid1_add = min_add,max_add - if (srch_mask(grid1_add)) then - n = n+1 - srch_add_loc_get_srch_cells(n) = grid1_add - srch_corner_lat_loc_get_srch_cells(:,n) = - & grid1_corner_lat(:,grid1_add) - srch_corner_lon_loc_get_srch_cells(:,n) = - & grid1_corner_lon(:,grid1_add) - srch_center_lat_loc_get_srch_cells(n) = - & grid1_center_lat(grid1_add) - srch_center_lon_loc_get_srch_cells(n) = - & grid1_center_lon(grid1_add) - endif - end do - - srch_corners_loc_get_srch_cells = grid1_corners - endif - - deallocate(srch_mask) - - else - - !*** Grid 2 neighbors of grid 1 cell - - allocate(srch_mask(grid2_size)) - - min_add = grid2_size - max_add = 1 - do n=1,num_srch_bins - if (cell_add >= bin_addr1(1,n) .and. - & cell_add <= bin_addr1(2,n)) then - min_add = min(min_add, bin_addr2(1,n)) - max_add = max(max_add, bin_addr2(2,n)) - endif - end do - - !*** - !*** further restrict searches using bounding boxes - !*** - - num_srch_cells_loc_get_srch_cells = 0 - do grid2_add = min_add,max_add - srch_mask(grid2_add) = - & (grid2_bound_box(1,grid2_add) <= - & grid1_bound_box(2,cell_add)) .and. - & (grid2_bound_box(2,grid2_add) >= - & grid1_bound_box(1,cell_add)) .and. - & (grid2_bound_box(3,grid2_add) <= - & grid1_bound_box(4,cell_add)) .and. - & (grid2_bound_box(4,grid2_add) >= - & grid1_bound_box(3,cell_add)) - - - - if (srch_mask(grid2_add)) - & num_srch_cells_loc_get_srch_cells = - & num_srch_cells_loc_get_srch_cells+1 - end do - - - if (num_srch_cells_loc_get_srch_cells /= 0) then - - !*** - !*** create search arrays - !*** - - allocate(srch_add_loc_get_srch_cells( - & num_srch_cells_loc_get_srch_cells), - & srch_corner_lat_loc_get_srch_cells( - & grid2_corners,num_srch_cells_loc_get_srch_cells), - & srch_corner_lon_loc_get_srch_cells( - & grid2_corners,num_srch_cells_loc_get_srch_cells), - & srch_center_lat_loc_get_srch_cells( - & num_srch_cells_loc_get_srch_cells), - & srch_center_lon_loc_get_srch_cells( - & num_srch_cells_loc_get_srch_cells)) - - n = 0 - do grid2_add = min_add,max_add - if (srch_mask(grid2_add)) then - n = n+1 - srch_add_loc_get_srch_cells(n) = grid2_add - srch_corner_lat_loc_get_srch_cells(:,n) = - & grid2_corner_lat(:,grid2_add) - srch_corner_lon_loc_get_srch_cells(:,n) = - & grid2_corner_lon(:,grid2_add) - srch_center_lat_loc_get_srch_cells(n) = - & grid2_center_lat(grid2_add) - srch_center_lon_loc_get_srch_cells(n) = - & grid2_center_lon(grid2_add) - endif - end do - - srch_corners_loc_get_srch_cells = grid2_corners - endif - - deallocate(srch_mask) - endif - - else - - if (srch_grid_num == 1) then - - !*** Grid 1 neighbors of grid 2 cell - - allocate(srch_mask(grid1_size)) - - min_add = grid1_size - max_add = 1 - do n=1,num_srch_bins - if (cell_add >= bin_addr2(1,n) .and. - & cell_add <= bin_addr2(2,n)) then - min_add = min(min_add, bin_addr1(1,n)) - max_add = max(max_add, bin_addr1(2,n)) - endif - end do - - !*** - !*** further restrict searches using bounding boxes - !*** - - num_srch_cells_loc_get_srch_cells = 0 - do grid1_add = min_add,max_add - srch_mask(grid1_add) = - & (grid1_bound_box(1,grid1_add) <= - & grid2_bound_box(2,cell_add)) .and. - & (grid1_bound_box(2,grid1_add) >= - & grid2_bound_box(1,cell_add)) .and. - & (grid1_bound_box(3,grid1_add) <= - & grid2_bound_box(4,cell_add)) .and. - & (grid1_bound_box(4,grid1_add) >= - & grid2_bound_box(3,cell_add)) - - if (srch_mask(grid1_add)) - & num_srch_cells_loc_get_srch_cells = - & num_srch_cells_loc_get_srch_cells+1 - end do - - - if (num_srch_cells_loc_get_srch_cells /= 0) then - - !*** - !*** create search arrays - !*** - - allocate(srch_add_loc_get_srch_cells( - & num_srch_cells_loc_get_srch_cells), - & srch_corner_lat_loc_get_srch_cells( - & grid1_corners,num_srch_cells_loc_get_srch_cells), - & srch_corner_lon_loc_get_srch_cells( - & grid1_corners,num_srch_cells_loc_get_srch_cells), - & srch_center_lat_loc_get_srch_cells( - & num_srch_cells_loc_get_srch_cells), - & srch_center_lon_loc_get_srch_cells( - & num_srch_cells_loc_get_srch_cells)) - - n = 0 - do grid1_add = min_add,max_add - if (srch_mask(grid1_add)) then - n = n+1 - srch_add_loc_get_srch_cells(n) = grid1_add - srch_corner_lat_loc_get_srch_cells(:,n) = - & grid1_corner_lat(:,grid1_add) - srch_corner_lon_loc_get_srch_cells(:,n) = - & grid1_corner_lon(:,grid1_add) - srch_center_lat_loc_get_srch_cells(n) = - & grid1_center_lat(grid1_add) - srch_center_lon_loc_get_srch_cells(n) = - & grid1_center_lon(grid1_add) - endif - end do - - srch_corners_loc_get_srch_cells = grid1_corners - endif - - deallocate(srch_mask) - - else - - !*** Grid 2 neighbors of grid 2 cell - - allocate(srch_mask(grid2_size)) - - min_add = grid2_size - max_add = 1 - do n=1,num_srch_bins - if (cell_add >= bin_addr2(1,n) .and. - & cell_add <= bin_addr2(2,n)) then - min_add = min(min_add, bin_addr2(1,n)) - max_add = max(max_add, bin_addr2(2,n)) - endif - end do - - !*** - !*** further restrict searches using bounding boxes - !*** - - num_srch_cells_loc_get_srch_cells = 0 - do grid2_add = min_add,max_add - srch_mask(grid2_add) = - & (grid2_bound_box(1,grid2_add) <= - & grid2_bound_box(2,cell_add)) .and. - & (grid2_bound_box(2,grid2_add) >= - & grid2_bound_box(1,cell_add)) .and. - & (grid2_bound_box(3,grid2_add) <= - & grid2_bound_box(4,cell_add)) .and. - & (grid2_bound_box(4,grid2_add) >= - & grid2_bound_box(3,cell_add)) - - if (srch_mask(grid2_add)) - & num_srch_cells_loc_get_srch_cells = - & num_srch_cells_loc_get_srch_cells+1 - end do - - - if (num_srch_cells_loc_get_srch_cells /= 0) then - - !*** - !*** create search arrays - !*** - - allocate(srch_add_loc_get_srch_cells( - & num_srch_cells_loc_get_srch_cells), - & srch_corner_lat_loc_get_srch_cells( - & grid2_corners,num_srch_cells_loc_get_srch_cells), - & srch_corner_lon_loc_get_srch_cells( - & grid2_corners,num_srch_cells_loc_get_srch_cells), - & srch_center_lat_loc_get_srch_cells( - & num_srch_cells_loc_get_srch_cells), - & srch_center_lon_loc_get_srch_cells( - & num_srch_cells_loc_get_srch_cells)) - - n = 0 - do grid2_add = min_add,max_add - if (srch_mask(grid2_add)) then - n = n+1 - srch_add_loc_get_srch_cells(n) = grid2_add - srch_corner_lat_loc_get_srch_cells(:,n) = - & grid2_corner_lat(:,grid2_add) - srch_corner_lon_loc_get_srch_cells(:,n) = - & grid2_corner_lon(:,grid2_add) - srch_center_lat_loc_get_srch_cells(n) = - & grid2_center_lat(grid2_add) - srch_center_lon_loc_get_srch_cells(n) = - & grid2_center_lon(grid2_add) - endif - end do - - srch_corners_loc_get_srch_cells = grid2_corners - endif - - deallocate(srch_mask) - - endif - - endif - - endif - - - num_srch_cells = num_srch_cells_loc_get_srch_cells - - if (num_srch_cells .eq. 0) then - return - endif - - srch_corners = srch_corners_loc_get_srch_cells - allocate(srch_add(num_srch_cells), - & srch_corner_lat(srch_corners,num_srch_cells), - & srch_corner_lon(srch_corners,num_srch_cells), - & srch_center_lat(num_srch_cells), - & srch_center_lon(num_srch_cells)) - srch_add = srch_add_loc_get_srch_cells - srch_corner_lat = srch_corner_lat_loc_get_srch_cells - srch_corner_lon = srch_corner_lon_loc_get_srch_cells - srch_center_lat = srch_center_lat_loc_get_srch_cells - srch_center_lon = srch_center_lon_loc_get_srch_cells - - end subroutine get_srch_cells - - -!********************************************************************** - - -!---------------------------------------------------------------------- -! -! Find cell adjacent to edge (edge_id) of given cell (cell_add) -! -!---------------------------------------------------------------------- - - subroutine find_adj_cell(cell_add, edge_id, cell_grid_num, - & adj_add) - -!---------------------------------------------------------------------- -! -! Input variables -! -!---------------------------------------------------------------------- - - integer (SCRIP_i4), intent(in) :: - & cell_add, ! cell whose edge we are checking - & edge_id, ! index of edge that we are check - & cell_grid_num ! grid to which cell belongs - -!---------------------------------------------------------------------- -! -! Output variables -! -!---------------------------------------------------------------------- - - integer (SCRIP_i4), intent(out) :: adj_add - -!---------------------------------------------------------------------- -! -! Local variables -! -!---------------------------------------------------------------------- - - integer (SCRIP_i4) :: i, inx, n, global_add - logical (SCRIP_logical) :: found - real (SCRIP_r8) :: lat1, lon1, lat2, lon2 - - adj_add = 0 - - if (cell_grid_num .eq. 1) then - - i = edge_id - inx = 1 + mod(edge_id,grid1_corners) - - lat1 = grid1_corner_lat(i,cell_add) - lon1 = grid1_corner_lon(i,cell_add) - lat2 = grid1_corner_lat(inx,cell_add) - lon2 = grid1_corner_lon(inx,cell_add) - - !*** - !*** Often the cell with the next or previous index is - !*** the adjacent cell. Check that first - !*** - - if (cell_add .lt. grid1_size) then - - global_add = cell_add + 1 - - do i = 1, grid1_corners - inx = mod(i,grid1_corners)+1 - if (abs(grid1_corner_lat(inx,global_add)-lat1) .le. tiny - & .and. - & abs(grid1_corner_lat(i,global_add)-lat2) .le. tiny - & .and. - & abs(grid1_corner_lon(inx,global_add)-lon1) .le. tiny - & .and. - & abs(grid1_corner_lon(i,global_add)-lon2) .le. tiny) - & then - - adj_add = global_add - return - endif - enddo - - endif - - if (cell_add .gt. 1) then - - global_add = cell_add - 1 - - do i = 1, grid1_corners - inx = mod(i,grid1_corners)+1 - if (abs(grid1_corner_lat(inx,global_add)-lat1) .le. tiny - & .and. - & abs(grid1_corner_lat(i,global_add)-lat2) .le. tiny - & .and. - & abs(grid1_corner_lon(inx,global_add)-lon1) .le. tiny - & .and. - & abs(grid1_corner_lon(i,global_add)-lon2) .le. tiny) - & then - - adj_add = global_add - return - endif - enddo - - endif - - - - else - - i = edge_id - inx = 1 + mod(edge_id,grid2_corners) - - lat1 = grid2_corner_lat(i,cell_add) - lon1 = grid2_corner_lon(i,cell_add) - lat2 = grid2_corner_lat(inx,cell_add) - lon2 = grid2_corner_lon(inx,cell_add) - - - !*** - !*** Often the cell with the next or previous index is - !*** the adjacent cell. Check that first - !*** - - if (cell_add .lt. grid2_size) then - - global_add = cell_add + 1 - - do i = 1, grid2_corners - inx = mod(i,grid2_corners)+1 - if (abs(grid2_corner_lat(inx,global_add)-lat1) .le. tiny - & .and. - & abs(grid2_corner_lat(i,global_add)-lat2) .le. tiny - & .and. - & abs(grid2_corner_lon(inx,global_add)-lon1) .le. tiny - & .and. - & abs(grid2_corner_lon(i,global_add)-lon2) .le. tiny) - & then - - adj_add = global_add - return - endif - enddo - - endif - - if (cell_add .gt. 1) then - - global_add = cell_add - 1 - - do i = 1, grid2_corners - inx = mod(i,grid2_corners)+1 - if (abs(grid2_corner_lat(inx,global_add)-lat1) .le. tiny - & .and. - & abs(grid2_corner_lat(i,global_add)-lat2) .le. tiny - & .and. - & abs(grid2_corner_lon(inx,global_add)-lon1) .le. tiny - & .and. - & abs(grid2_corner_lon(i,global_add)-lon2) .le. tiny) - & then - - adj_add = global_add - return - endif - enddo - - endif - - - endif - - - if (cell_add /= last_cell_find_adj_cell .or. - & cell_grid_num /= last_cell_grid_num_find_adj_cell) then - - last_cell_find_adj_cell = cell_add - last_cell_grid_num_find_adj_cell = cell_grid_num - - if (first_call_find_adj_cell) then - first_call_find_adj_cell = .false. - last_cell_find_adj_cell = 0 - last_cell_grid_num_find_adj_cell = 0 - else - if (num_srch_cells_find_adj_cell .gt. 0) then - deallocate(srch_add_find_adj_cell, - & srch_corner_lat_find_adj_cell, - & srch_corner_lon_find_adj_cell, - & srch_center_lat_find_adj_cell, - & srch_center_lon_find_adj_cell) - endif - endif - - call get_srch_cells(cell_add, cell_grid_num, cell_grid_num, - & num_srch_cells_find_adj_cell, srch_add_find_adj_cell, - & srch_corners_find_adj_cell, srch_corner_lat_find_adj_cell, - & srch_corner_lon_find_adj_cell, - & srch_center_lat_find_adj_cell, - & srch_center_lon_find_adj_cell) - - endif - - - found = .false. - do n = 1, num_srch_cells_find_adj_cell - - global_add = srch_add_find_adj_cell(n) - - do i = 1, srch_corners_find_adj_cell - inx = mod(i,srch_corners_find_adj_cell)+1 - if (abs(srch_corner_lat_find_adj_cell(inx,n)-lat1) .le. tiny - & .and. - & abs(srch_corner_lat_find_adj_cell(i,n)-lat2) .le. tiny - & .and. - & abs(srch_corner_lon_find_adj_cell(inx,n)-lon1) .le.tiny - & .and. - & abs(srch_corner_lon_find_adj_cell(i,n)-lon2) .le. tiny) - & then - - adj_add = global_add - found = .true. - - exit - endif - enddo - - if (found) exit - - enddo - - return - end subroutine find_adj_cell - - -!---------------------------------------------------------------------- -! -! Given points inside and outside a cell, converge to the boundary -! -!---------------------------------------------------------------------- - - - subroutine converge_to_bdry(cell_add, cell_grid_num, - & ncorners, cell_corner_lat, - & cell_corner_lon, cell_center_lat, cell_center_lon, - & inpt_lat, inpt_lon, outpt_lat, outpt_lon, - & bpt_lat, bpt_lon, bedgeid) - -!---------------------------------------------------------------------- -! -! Input variables -! -!---------------------------------------------------------------------- - - integer (SCRIP_i4), intent(in) :: - & cell_add, ! Cell in which we are operating - & cell_grid_num, ! Grid to which cell belongs - & ncorners ! Number of corners in cell - - real (SCRIP_r8), dimension(ncorners), intent(in) :: - & cell_corner_lat, ! Latitude values of cell corners - & cell_corner_lon ! Longitude values of cell corners - - real (SCRIP_r8), intent(in) :: - & cell_center_lat, ! Latitude of cell center - & cell_center_lon, ! Longitude of cell center, - & inpt_lat, ! Latitude of inside point - & inpt_lon, ! Longitude of inside point - & outpt_lat, ! Latitude of outside point - & outpt_lon ! Longitude of outside point - - -!---------------------------------------------------------------------- -! -! Output variables -! -!---------------------------------------------------------------------- - - real (SCRIP_r8), intent(out) :: - & bpt_lat, ! Latitude of boundary point - & bpt_lon ! Longitude of boundary point - - integer (SCRIP_i4), intent(out) :: - & bedgeid ! ID of edge that point converged to - -!---------------------------------------------------------------------- -! -! Local variables -! -!---------------------------------------------------------------------- - - logical (SCRIP_logical) :: - & converged, - & lboundary, - & inpoly - - integer (SCRIP_i4) :: - & it - - real (SCRIP_r8) :: - & lat1, lon1, - & lat2, lon2, - & midlat, midlon - - bedgeid = 0 - - lat1 = inpt_lat - lon1 = inpt_lon - lat2 = outpt_lat - lon2 = outpt_lon - - - converged = .false. - it = 0 - do while (.not. converged) - - midlat = (lat1+lat2)/2.0 - if (abs(lon1-lon2) < pi) then - midlon = (lon1+lon2)/2.0 - else - midlon = (lon1+lon2)/2.0 - pi2 - endif - - - call ptincell(midlat, midlon, - & cell_add, ncorners, - & cell_corner_lat, cell_corner_lon, - & cell_center_lat, cell_center_lon, - & cell_grid_num, - & inpoly, lboundary, bedgeid) - - if (inpoly) then - lat1 = midlat - lon1 = midlon - else - lat2 = midlat - lon2 = midlon - endif - - if (abs(lat1-lat2) < tiny .and. - & abs(lon1-lon2) < tiny .and. lboundary) then - converged = .true. - endif - - if (it > 100) then - exit - endif - - it = it + 1 - enddo ! do while (not converged) - - - bpt_lat = midlat - bpt_lon = midlon - - end subroutine converge_to_bdry - - - - - end module scrip_remap_conservative - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 54835eca995ebfab8061acae745f4cc5c15e32bc Mon Sep 17 00:00:00 2001 From: jcwarner-USGS Date: Tue, 10 Sep 2024 15:47:11 -0400 Subject: [PATCH 5/9] update scrip_remap_conservative.F with SCRIPMPI, switches.json, and src_list.cmake --- model/src/SCRIP/scrip_remap_conservative.F | 6853 ++++++++++++++++++++ 1 file changed, 6853 insertions(+) create mode 100755 model/src/SCRIP/scrip_remap_conservative.F diff --git a/model/src/SCRIP/scrip_remap_conservative.F b/model/src/SCRIP/scrip_remap_conservative.F new file mode 100755 index 000000000..96c91d40a --- /dev/null +++ b/model/src/SCRIP/scrip_remap_conservative.F @@ -0,0 +1,6853 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! this module contains necessary routines for computing addresses +! and weights for a conservative interpolation between any two +! grids on a sphere. the weights are computed by performing line +! integrals around all overlap regions of the two grids. see +! Dukowicz and Kodis, SIAM J. Sci. Stat. Comput. 8, 305 (1987) and +! Jones, P.W. Monthly Weather Review (submitted). +! +!----------------------------------------------------------------------- +! +! CVS:$Id: remap_conserv.f,v 1.10 2001/08/21 21:05:13 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +! This code has been modified from the version available from +! Los Alamos National Laboratory, for the purpose of running it +! within WW3. Primary modifications: +! - renamed many variables to be unique across the code +! - "save" variables moved from subroutine to module so that +! we can "clear" them later. +! - print statements added. +! - phi_or_theta = 2 instead of phi_or_theta = 1 (important!) +! +!*********************************************************************** +! Modifications introduced by M. Dutour (MD) for +! running with WAVEWATCH III ... see below +! +! +! BE CAREFUL ABOUT EXPLICIT INITIALIZATION OF VARIABLES IN +! MULTI-THREADED VERSION OF THE CODE - INLINE INITIALIZATION OF +! A VARIABLE IN FORTRAN 90/95 MAKES THE VARIABLE IMPLICITLY STATIC. +! OPENMP FORCES _ALL_ FORTRAN IMPLEMENTATIONS TO MAKE THE VARIABLE +! STATIC (OR OF THE TYPE SAVE) IF IT IS INITIALIZED IN THE +! DECLARATION LINE +! +! + + module scrip_remap_conservative + +!----------------------------------------------------------------------- + + use SCRIP_KindsMod ! defines common data types + use SCRIP_constants ! defines common constants + use scrip_timers ! module for timing + use scrip_grids ! module containing grid information + use scrip_remap_vars ! module containing remap information + use omp_lib + + implicit none + + integer (SCRIP_i4) :: nthreads=2 ! Number of parallel threads + +!............variables that needed to be moved from "local level" to +!............ "module level" in order that we can clear them later. +!............These are all local variables that had the "save" attribute +!............in the standard version of SCRIP + + integer (SCRIP_i4), save :: + & avoid_pole_count = 0 ! count attempts to avoid pole + + real (SCRIP_r8), save :: + & avoid_pole_offset = tiny ! endpoint offset to avoid pole + + integer (SCRIP_i4), dimension(:,:), allocatable, save :: + & link_add1, ! min,max link add to restrict search + & link_add2 ! min,max link add to restrict search + + logical (SCRIP_logical), save :: + & first_call_store_link_cnsrv = .true. + + logical (SCRIP_logical), save :: + & first_call_locate_segstart= .true. + + integer (SCRIP_i4), save :: + & last_cell_locate_segstart=0, ! save the search parameters + & last_cell_grid_num_locate_segstart=0, ! if unchanged, reuse + ! search lists + & last_srch_grid_num_locate_segstart=0 + + integer (SCRIP_i4), save :: + & num_srch_cells_locate_segstart=0, + & srch_corners_locate_segstart ! number of corners for + ! each cell + + integer (SCRIP_i4), dimension(:), allocatable, save :: + & srch_add_locate_segstart ! global address of cells + ! in srch arrays + + real (SCRIP_r8), dimension(:,:), allocatable, save :: + & srch_corner_lat_locate_segstart, ! lat of each corner of + ! srch cells + & srch_corner_lon_locate_segstart ! lon of each corner of + ! srch cells + + real(SCRIP_r8), dimension(:), allocatable, save :: + & srch_center_lat_locate_segstart,! lat of center of srch cells + & srch_center_lon_locate_segstart ! lon of center of srch cells + + logical (SCRIP_logical), save :: + & first_call_locate_point= .true. + + integer (SCRIP_i4), save :: + & last_cell_locate_point=0, ! save the search parameters + & last_cell_grid_num_locate_point=0, ! if unchanged, reuse + ! search lists + & last_srch_grid_num_locate_point=0 + + integer (SCRIP_i4), save :: + & num_srch_cell_locate_points=0, + & srch_corners_locate_point ! number of corners for each cell + + integer (SCRIP_i4), dimension(:), allocatable, save :: + & srch_add_locate_point ! global address of cells in + ! srch arrays + + real (SCRIP_r8), dimension(:,:), allocatable, save :: + & srch_corner_lat_locate_point, ! lat of each corner of srch + ! cells + & srch_corner_lon_locate_point ! lon of each corner of srch + ! cells + + real (SCRIP_r8), dimension(:), allocatable, save :: + & srch_center_lat_locate_point, ! lat of center of srch cells + & srch_center_lon_locate_point ! lon of center of srch cells + + integer (SCRIP_i4), save :: + & num_srch_cells_loc_get_srch_cells, ! Number of srch cells + ! found + & srch_corners_loc_get_srch_cells ! Number of corners for + ! search cells + + integer (SCRIP_i4), dimension(:), allocatable, save :: + & srch_add_loc_get_srch_cells ! Global addresses of + ! search cells + + real (SCRIP_r8), dimension(:,:), allocatable, save :: + & srch_corner_lat_loc_get_srch_cells, + & srch_corner_lon_loc_get_srch_cells + + real (SCRIP_r8), dimension(:), allocatable, save :: + & srch_center_lat_loc_get_srch_cells, + & srch_center_lon_loc_get_srch_cells + + integer (SCRIP_i4), save :: + & last_cell_add_get_srch_cells, + & last_cell_grid_num_get_srch_cells, + & last_srch_grid_num_get_srch_cells + + logical (SCRIP_logical), save :: + & first_call_get_srch_cells=.true. + + logical (SCRIP_logical), save :: + & first_call_find_adj_cell=.true. + + logical (SCRIP_logical), private :: is_master + ! module's equivalent of "l_master" + + integer (SCRIP_i4), save :: + & last_cell_find_adj_cell, + & last_cell_grid_num_find_adj_cell, + & num_srch_cells_find_adj_cell, + & srch_corners_find_adj_cell + + integer (SCRIP_i4), dimension(:), allocatable, save :: + & srch_add_find_adj_cell + real (SCRIP_r8), dimension(:,:), allocatable, save :: + & srch_corner_lat_find_adj_cell, srch_corner_lon_find_adj_cell + + real (SCRIP_r8), dimension(:), allocatable, save :: + & srch_center_lat_find_adj_cell, srch_center_lon_find_adj_cell + +C$OMP THREADPRIVATE(last_cell_grid_num_get_srch_cells, +C$OMP& last_srch_grid_num_get_srch_cells, +C$OMP& first_call_get_srch_cells, +C$OMP& last_cell_add_get_srch_cells, +C$OMP& num_srch_cells_loc_get_srch_cells, +C$OMP& srch_corners_loc_get_srch_cells, +C$OMP& srch_add_loc_get_srch_cells, +C$OMP& srch_corner_lat_loc_get_srch_cells, +C$OMP& srch_corner_lon_loc_get_srch_cells, +C$OMP& srch_center_lat_loc_get_srch_cells, +C$OMP& srch_center_lon_loc_get_srch_cells) + +C$OMP THREADPRIVATE(first_call_locate_segstart, +C$OMP& last_cell_locate_segstart, +C$OMP& last_cell_grid_num_locate_segstart, +C$OMP& last_srch_grid_num_locate_segstart, +C$OMP& num_srch_cells_locate_segstart, +C$OMP& srch_corners_locate_segstart, +C$OMP& srch_add_locate_segstart, +C$OMP& srch_corner_lat_locate_segstart, +C$OMP& srch_corner_lon_locate_segstart, +C$OMP& srch_center_lat_locate_segstart, +C$OMP& srch_center_lon_locate_segstart) + +C$OMP THREADPRIVATE(first_call_locate_point, +C$OMP& last_cell_locate_point, +C$OMP& last_cell_grid_num_locate_point, +C$OMP& last_srch_grid_num_locate_point, +C$OMP& num_srch_cell_locate_points, +C$OMP& srch_add_locate_point,srch_corner_lat_locate_point, +C$OMP& srch_corner_lon_locate_point, +C$OMP& srch_center_lat_locate_point, +C$OMP& srch_center_lon_locate_point) + +C$OMP THREADPRIVATE(first_call_find_adj_cell, +C$OMP& last_cell_find_adj_cell, +C$OMP& last_cell_grid_num_find_adj_cell, +C$OMP& num_srch_cells_find_adj_cell, +C$OMP& srch_corners_find_adj_cell, +C$OMP& srch_add_find_adj_cell, +C$OMP& srch_corner_lat_find_adj_cell, +C$OMP& srch_corner_lon_find_adj_cell, +C$OMP& srch_center_lat_find_adj_cell, +C$OMP& srch_center_lon_find_adj_cell) + +!*********************************************************************** + + contains + +!*********************************************************************** + + subroutine remap_conserv(l_master, l_test) + +!----------------------------------------------------------------------- +! +! this routine traces the perimeters of every grid cell on each +! grid checking for intersections with the other grid and computing +! line integrals for each subsegment. +! +!----------------------------------------------------------------------- + +#ifdef W3_SCRIPMPI + USE W3ADATMD, ONLY: MPI_COMM_WAVE + USE W3ODATMD, ONLY: IAPROC, NTPROC + INCLUDE "mpif.h" +#endif + logical(SCRIP_Logical), intent(in) :: l_master ! Am I the master + ! processor (do I/O)? + logical(SCRIP_Logical), intent(in) :: l_test ! Whether to + !include test output + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- +#ifdef W3_SCRIPMPI + integer (SCRIP_i4) :: grid1_str, grid1_end, grid2_str, grid2_end + integer (SCRIP_i4) :: IERR_MPI, IPROC, ratio + integer (SCRIP_i4) :: j, ij, add1, add2, got_weight + integer (SCRIP_i4) :: nlink, min_link, max_link + integer (SCRIP_i4), dimension(MPI_STATUS_SIZE) :: status + integer (SCRIP_i4), dimension(:), allocatable :: Numlinks + integer (SCRIP_i4), dimension(:), allocatable :: Asendi + integer (SCRIP_i4), dimension(:), allocatable :: Arecv1 + integer (SCRIP_i4), dimension(:), allocatable :: Arecv2 +#endif + + integer (SCRIP_i4), parameter :: + & phi_or_theta = 2 ! integrate w.r.t. phi (1) or theta (2) + + integer (SCRIP_i4) :: + & i, inext, ! + & n, nwgt, + & grid1_add, ! Current linear address for grid1 cell + & grid2_add, ! Current linear address for grid2 cell + & grid_num, ! Index (1,2) of grid that we are + ! processing + & opp_grid_num, ! Index of opposite grid (2,1) + & maxrd_cell, ! cell with the max. relative difference + ! in area + & progint, ! Intervals at which progress is to be + ! printed + & icount ! for counting + + real (SCRIP_r8) :: + & norm_factor ! factor for normalizing wts + + real (SCRIP_r8), dimension(6) :: + & weights ! Weights array + + real (SCRIP_r8) :: + & beglat, beglon, + & endlat, endlon, + & ave_reldiff, ! Average rel. diff. in areas + & max_reldiff, ! Maximum rel. diff in areas + & maxrd_area, ! Computed area for cell with max rel + ! diff + & maxrd_true ! True area for cell with max rel diff + + real (SCRIP_r8), dimension(:), allocatable :: + & reldiff, ! Relative difference in computed + ! and true area + & ref_area ! Area of cell as computed by direct + ! integration around its boundaries +#ifdef W3_SCRIPMPI + real (SCRIP_r8), dimension(:), allocatable :: Asend + real (SCRIP_r8), dimension(:), allocatable :: Arecvw + real (SCRIP_r8), dimension(:), allocatable :: Arecv + real (SCRIP_r8), dimension(:,:), allocatable :: Arecvw2d +#endif + +! call OMP_SET_DYNAMIC(.FALSE.) + +!----------------------------------------------------------------------- +! +! integrate around each cell on grid1 +! +!----------------------------------------------------------------------- + + is_master=l_master ! set module variable using subroutine input + ! argument variable. + ! Use the former subsequently. + + if(is_master)print *,'grid1 sweep' + +!NRL Progress is slow when the other grid (grid 2) is large, so we use +!NRL that. Really, it would be a better to do this with a timer... + if (grid2_size > 500000) then + progint = 1000 + elseif (grid2_size > 250000) then + progint = 2000 + elseif (grid2_size > 100000) then + progint = 5000 + else + progint = 10000 + endif + + grid_num = 1 + opp_grid_num = 2 + + call timer_start(1) + +C$OMP PARALLEL DEFAULT(SHARED) PRIVATE(grid1_add) NUM_THREADS(nthreads) + +C$OMP DO SCHEDULE(DYNAMIC) + + +#ifdef W3_SCRIPMPI +! +! To do this in mpi, we will just break up the sweep loops into chunks. Then +! gather all of the data at end of each loop so that each proc has a full set of +! data. First we want to determine start and end chunks for this processor. +! +! Revert back to 0 based processor number. + IPROC=IAPROC-1 + IF (NTPROC.eq.1) THEN + grid1_str=1 + grid1_end=grid1_size + ELSE + ratio=INT(grid1_size/NTPROC) + grid1_str=(IPROC*ratio)+1 + grid1_end=grid1_str+ratio-1 + IF (IPROC+1.eq.NTPROC) grid1_end=grid1_size + END IF +#else + grid1_str=1 + grid1_end=grid1_size +#endif + do grid1_add = grid1_str,grid1_end + + if (mod(grid1_add,progint) .eq. 0 .and. is_master) then + print *, grid1_add,' of ',grid1_size,' cells processed ...' + endif + + call cell_integrate(grid1_add, grid_num, phi_or_theta) + + end do ! do grid1_add=... + +C$OMP END DO + +C$OMP END PARALLEL + + +#ifdef W3_SCRIPMPI +! +! Here we need to gather all the data processed and +! send to each proc so they know the full data set. +! +! grid1 integrate +! + allocate (Asend(grid1_size)) + allocate (Arecv(grid1_size)) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Work on grid1_frac(grid1_size) +! zero it out. + DO grid1_add=1,grid1_size + Asend(grid1_add)=zero + Arecv(grid1_add)=zero + END DO +! fill the send for this tile. + DO grid1_add=grid1_str,grid1_end + Asend(grid1_add)=grid1_frac(grid1_add) + END DO + call mpi_allreduce(Asend, Arecv, grid1_size, MPI_DOUBLE, & + & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) +! fill the working array as a sum from all nodes. + DO grid1_add=1,grid1_size + grid1_frac(grid1_add)=Arecv(grid1_add) + END DO +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Work on grid1_area(grid1_size) +! zero it out. + DO grid1_add=1,grid1_size + Asend(grid1_add)=zero + Arecv(grid1_add)=zero + END DO +! fill the send for this tile. + DO grid1_add=grid1_str,grid1_end + Asend(grid1_add)=grid1_area(grid1_add) + END DO + call mpi_allreduce(Asend, Arecv, grid1_size, MPI_DOUBLE, & + & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) +! fill the working array as a sum from all nodes. + DO grid1_add=1,grid1_size + grid1_area(grid1_add)=Arecv(grid1_add) + END DO +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Work on grid1_centroid_lat(grid1_size) +! zero it out. + DO grid1_add=1,grid1_size + Asend(grid1_add)=zero + Arecv(grid1_add)=zero + END DO +! fill the send for this tile. + DO grid1_add=grid1_str,grid1_end + Asend(grid1_add)=grid1_centroid_lat(grid1_add) + END DO + call mpi_allreduce(Asend, Arecv, grid1_size, MPI_DOUBLE, & + & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) +! fill the working array as a sum from all nodes. + DO grid1_add=1,grid1_size + grid1_centroid_lat(grid1_add)=Arecv(grid1_add) + END DO +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Work on grid1_centroid_lon(grid1_size) +! zero it out. + DO grid1_add=1,grid1_size + Asend(grid1_add)=zero + Arecv(grid1_add)=zero + END DO +! fill the send for this tile. + DO grid1_add=grid1_str,grid1_end + Asend(grid1_add)=grid1_centroid_lon(grid1_add) + END DO + call mpi_allreduce(Asend, Arecv, grid1_size, MPI_DOUBLE, & + & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) +! fill the working array as a sum from all nodes. + DO grid1_add=1,grid1_size + grid1_centroid_lon(grid1_add)=Arecv(grid1_add) + END DO + deallocate(Asend, Arecv) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + allocate (Asend(grid2_size)) + allocate (Arecv(grid2_size)) +! Work on grid2_frac(grid2_size) +! zero it out. + DO grid2_add=1,grid2_size + Asend(grid2_add)=zero + Arecv(grid2_add)=zero + END DO +! fill the send for this tile. + DO grid2_add=1,grid2_size + Asend(grid2_add)=grid2_frac(grid2_add) + END DO + call mpi_allreduce(Asend, Arecv, grid2_size, MPI_DOUBLE, & + & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) +! fill the working array as a sum from all nodes. + DO grid2_add=1,grid2_size + grid2_frac(grid2_add)=Arecv(grid2_add) + END DO + deallocate(Asend, Arecv) +#endif + +!----------------------------------------------------------------------- +! +! integrate around each cell on grid2 +! +!----------------------------------------------------------------------- + + if(is_master)print *,'grid2 sweep ' + +!NRL Progress is slow when the other grid (grid 1) is large, so we use +!NRL that. + if (grid1_size > 500000) then + progint = 1000 + elseif (grid1_size > 250000) then + progint = 2000 + elseif (grid1_size > 100000) then + progint = 5000 + else + progint = 10000 + endif + + grid_num = 2 + opp_grid_num = 1 + + call timer_start(2) + +C$OMP PARALLEL DEFAULT(SHARED) PRIVATE(grid2_add) NUM_THREADS(nthreads) + +C$OMP DO SCHEDULE(DYNAMIC) + +#ifdef W3_SCRIPMPI +! +! To do this in mpi, we will just break up the sweep loops into chunks. Then +! gather all of the data at end of each loop so that each proc has a full set of +! data. First we want to determine start and end chunks for this processor. +! + IF (NTPROC.eq.1) THEN + grid2_str=1 + grid2_end=grid2_size + ELSE + ratio=INT(grid2_size/NTPROC) + grid2_str=(IPROC*ratio)+1 + grid2_end=grid2_str+ratio-1 + IF (IPROC+1.eq.NTPROC) grid2_end=grid2_size + END IF +#else + grid2_str=1 + grid2_end=grid2_size +#endif + do grid2_add = grid2_str,grid2_end + + if (mod(grid2_add,progint) .eq. 0 .and. is_master) then + print *, grid2_add,' of ',grid2_size,' cells processed ...' + endif + + call cell_integrate(grid2_add, grid_num, phi_or_theta) + + end do ! do grid2_add=... + +C$OMP END DO + +C$OMP END PARALLEL + + call timer_stop(2) + + +#ifdef W3_SCRIPMPI +! +! Here we need to gather all the data processed and +! send to each proc so they know the full data set. +! +! grid2 integrate +! + allocate (Asend(grid2_size)) + allocate (Arecv(grid2_size)) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Work on grid2_frac(grid2_size) +! zero it out. + DO grid2_add=1,grid2_size + Asend(grid2_add)=zero + Arecv(grid2_add)=zero + END DO +! fill the send for this tile. + DO grid2_add=grid2_str,grid2_end + Asend(grid2_add)=grid2_frac(grid2_add) + END DO + call mpi_allreduce(Asend, Arecv, grid2_size, MPI_DOUBLE, & + & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) +! fill the working array as a sum from all nodes. + DO grid2_add=1,grid2_size + grid2_frac(grid2_add)=Arecv(grid2_add) + END DO +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Work on grid2_area(grid2_size) +! zero it out. + DO grid2_add=1,grid2_size + Asend(grid2_add)=zero + Arecv(grid2_add)=zero + END DO +! fill the send for this tile. + DO grid2_add=grid2_str,grid2_end + Asend(grid2_add)=grid2_area(grid2_add) + END DO + call mpi_allreduce(Asend, Arecv, grid2_size, MPI_DOUBLE, & + & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) +! fill the working array as a sum from all nodes. + DO grid2_add=1,grid2_size + grid2_area(grid2_add)=Arecv(grid2_add) + END DO +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Work on grid2_centroid_lat(grid2_size) +! zero it out. + DO grid2_add=1,grid2_size + Asend(grid2_add)=zero + Arecv(grid2_add)=zero + END DO +! fill the send for this tile. + DO grid2_add=grid2_str,grid2_end + Asend(grid2_add)=grid2_centroid_lat(grid2_add) + END DO + call mpi_allreduce(Asend, Arecv, grid2_size, MPI_DOUBLE, & + & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) +! fill the working array as a sum from all nodes. + DO grid2_add=1,grid2_size + grid2_centroid_lat(grid2_add)=Arecv(grid2_add) + END DO +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Work on grid2_centroid_lon(grid2_size) +! zero it out. + DO grid2_add=1,grid2_size + Asend(grid2_add)=zero + Arecv(grid2_add)=zero + END DO +! fill the send for this tile. + DO grid2_add=grid2_str,grid2_end + Asend(grid2_add)=grid2_centroid_lon(grid2_add) + END DO + call mpi_allreduce(Asend, Arecv, grid2_size, MPI_DOUBLE, & + & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) +! fill the working array as a sum from all nodes. + DO grid2_add=1,grid2_size + grid2_centroid_lon(grid2_add)=Arecv(grid2_add) + END DO + deallocate(Asend, Arecv) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + allocate (Asend(grid1_size)) + allocate (Arecv(grid1_size)) +! Work on grid1_frac(grid1_size) +! zero it out. + DO grid1_add=1,grid1_size + Asend(grid1_add)=zero + Arecv(grid1_add)=zero + END DO +! fill the send for this tile. + DO grid1_add=1,grid1_size + Asend(grid1_add)=grid1_frac(grid1_add) + END DO + call mpi_allreduce(Asend, Arecv, grid1_size, MPI_DOUBLE, & + & MPI_SUM, MPI_COMM_WAVE, IERR_MPI) +! fill the working array as a sum from all nodes. + DO grid1_add=1,grid1_size + grid1_frac(grid1_add)=Arecv(grid1_add) + END DO + deallocate(Asend, Arecv) +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Both sweeps are now done. +! Here we need to gather all the data that was computed in +! store_link_cnsrv. Then we allow the Master node to +! compute the rest after these steps. +! +! gather total number of links that were computed on each processor. +! + allocate(Numlinks(NTPROC)) + call mpi_gather(num_links_map1, 1, MPI_INT, Numlinks, 1, MPI_INT, & + & 0, MPI_COMM_WAVE, IERR_MPI) +! +! Now gather all the weights from other nodes to make one combined set. +! + IF (IPROC.ne.0) THEN + allocate (Asendi(num_links_map1)) + Asendi=0 +! +! Send grid1 add map1. + DO i=1,num_links_map1 + Asendi(i)=grid1_add_map1(i) + END DO + call mpi_send(Asendi, num_links_map1, MPI_INT, 0, & + & 10, MPI_COMM_WAVE, IERR_MPI) +! +! Send grid2 add map1. + DO i=1,num_links_map1 + Asendi(i)=grid2_add_map1(i) + END DO + call mpi_send(Asendi, num_links_map1, MPI_INT, 0, & + & 20, MPI_COMM_WAVE, IERR_MPI) + deallocate (Asendi) +! +! Send wts map1. + allocate (Asend(num_links_map1*num_wts)) + Asend=0 + ij=0 + DO i=1,num_links_map1 + DO j=1,num_wts + ij=ij+1 + Asend(ij)=wts_map1(j,i) + END DO + END DO + call mpi_send(Asend, num_links_map1*num_wts, MPI_DOUBLE, 0, & + & 30, MPI_COMM_WAVE, IERR_MPI) + deallocate (Asend) + ELSE ! we are on the Master + DO i=2,NTPROC + allocate (Arecv1(Numlinks(i))) !grid1_add_map1 + allocate (Arecv2(Numlinks(i))) !grid2_add_map1 + allocate (Arecvw(num_wts*Numlinks(i))) !wts_map1 + allocate (Arecvw2d(num_wts,Numlinks(i))) !wts_map1 + Arecv1=0 + Arecv2=0 + Arecvw=zero + Arecvw2d=zero +! +! Receiving grd1 add map1 (grid1 area). +! + call mpi_recv(Arecv1, Numlinks(i), MPI_INT, i-1, 10, & + & MPI_COMM_WAVE, status, IERR_MPI) +! +! Receiving grid2 add map1 (grid2 area). +! + call mpi_recv(Arecv2, Numlinks(i), MPI_INT, i-1, 20, & + & MPI_COMM_WAVE, status, IERR_MPI) +! +! Receiving weights map1 +! + call mpi_recv(Arecvw, Numlinks(i)*num_wts, MPI_DOUBLE,i-1,30, & + & MPI_COMM_WAVE, status, IERR_MPI) +! restructure wts to be (1:num_wts,numlinks) + ij=0 + DO nlink=1,Numlinks(i) + DO j=1,num_wts + ij=ij+1 + Arecvw2d(j,nlink)=Arecvw(ij) + END DO + END DO +!----------------------------------------------------------------------- +! +! if the link already exists, add the weight to the current weight +! arrays +! This is taken from subroutine store_link_cnsrv. +!----------------------------------------------------------------------- + DO nlink=1,Numlinks(i) + add1=Arecv1(nlink) + add2=Arecv2(nlink) + got_weight=0 +! + min_link = min(link_add1(1,add1),link_add2(1,add2)) + max_link = max(link_add1(2,add1),link_add2(2,add2)) + if (min_link == 0) then + min_link = 1 + max_link = 0 + endif + do j=min_link,max_link + if (add1 == grid1_add_map1(j)) then + if (add2 == grid2_add_map1(j)) then + wts_map1(:,j)=wts_map1(:,j)+Arecvw2d(1:num_wts,nlink) + got_weight=1 + endif + endif + end do +!----------------------------------------------------------------------- +! +! if the link does not yet exist, increment number of links and +! check to see if remap arrays need to be increased to accomodate +! the new link. then store the link. +! +!----------------------------------------------------------------------- + if (got_weight.eq.0) then + num_links_map1 = num_links_map1 + 1 + if (num_links_map1 > max_links_map1) & + & call resize_remap_vars(1,resize_increment) + grid1_add_map1(num_links_map1) = add1 + grid2_add_map1(num_links_map1) = add2 + wts_map1 (:,num_links_map1) = Arecvw2d(1:num_wts,nlink) + END IF + + if (link_add1(1,add1) == 0) link_add1(1,add1)=num_links_map1 + if (link_add2(1,add2) == 0) link_add2(1,add2)=num_links_map1 + link_add1(2,add1) = num_links_map1 + link_add2(2,add2) = num_links_map1 + + END DO + deallocate (Arecv1, Arecv2, Arecvw, Arecvw2d) + END DO + END IF +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! Now distribute: num_links_map1, grid1_add_map1, grid2_add_map1, +! wts_map1, link_add1, link_add2, max_links_map1 +! +! send num_links_map1 +! + call mpi_bcast(num_links_map1, 1, MPI_INT, & + & 0, MPI_COMM_WAVE, IERR_MPI) +! force this + max_links_map1=num_links_map1 +! +! here we do what is in resize_remap_vars and just make the +! sizes of grid1_add_map1, grid2_add_map1, and wts_map1 to be +! the same size as on the 0 node. +! + IF (IPROC.ne.0) THEN + deallocate (grid1_add_map1, grid2_add_map1, wts_map1) + allocate ( grid1_add_map1(num_links_map1), & + & grid2_add_map1(num_links_map1), & + & wts_map1(num_wts,num_links_map1)) + END IF + IF (IPROC.eq.0) THEN +! +! Only save the valid parts of grid1_add_map1, grid2_add_map1, wts_map1 +! + allocate (Asendi(num_links_map1)) +! + DO i=1,num_links_map1 + Asendi(i)=grid1_add_map1(i) + END DO + deallocate (grid1_add_map1) + allocate ( grid1_add_map1(num_links_map1) ) + DO i=1,num_links_map1 + grid1_add_map1(i)=Asendi(i) + END DO +! + DO i=1,num_links_map1 + Asendi(i)=grid2_add_map1(i) + END DO + deallocate (grid2_add_map1) + allocate ( grid2_add_map1(num_links_map1) ) + DO i=1,num_links_map1 + grid2_add_map1(i)=Asendi(i) + END DO + deallocate (Asendi) +! + allocate (Arecvw2d(num_wts,num_links_map1)) !wts_map1 + DO i=1,num_links_map1 + DO j=1,num_wts + Arecvw2d(j,i)=wts_map1(j,i) + END DO + END DO + deallocate (wts_map1) + allocate ( wts_map1(num_wts,num_links_map1) ) + DO i=1,num_links_map1 + DO j=1,num_wts + wts_map1(j,i)=Arecvw2d(j,i) + END DO + END DO + deallocate (Arecvw2d) + END IF +! +! send grid1_add_map1 +! + allocate (Asendi(num_links_map1)) + Asendi=0 + IF (IPROC.eq.0) THEN + DO i=1,num_links_map1 + Asendi(i)=grid1_add_map1(i) + END DO + END IF + call mpi_bcast(Asendi, num_links_map1, MPI_INT, & + & 0, MPI_COMM_WAVE, IERR_MPI) + IF (IPROC.ne.0) THEN + DO i=1,num_links_map1 + grid1_add_map1(i)=Asendi(i) + END DO + END IF +! +! send grid2_add_map1 +! + Asendi=0 + IF (IPROC.eq.0) THEN + DO i=1,num_links_map1 + Asendi(i)=grid2_add_map1(i) + END DO + END IF + call mpi_bcast(Asendi, num_links_map1, MPI_INT, & + & 0, MPI_COMM_WAVE, IERR_MPI) + IF (IPROC.ne.0) THEN + DO i=1,num_links_map1 + grid2_add_map1(i)=Asendi(i) + END DO + END IF + deallocate (Asendi) +! +! send wts_map1 +! + allocate (Asend(num_links_map1*num_wts)) + Asend=zero +! + ij=0 + IF (IPROC.eq.0) THEN + DO i=1,num_links_map1 + DO j=1,num_wts + ij=ij+1 + Asend(ij)=wts_map1(j,i) + END DO + END DO + END IF + ij=num_links_map1*num_wts + call mpi_bcast(Asend, ij, MPI_DOUBLE, & + & 0, MPI_COMM_WAVE, IERR_MPI) + IF (IPROC.ne.0) THEN + wts_map1=zero + ij=0 + DO i=1,num_links_map1 + DO j=1,num_wts + ij=ij+1 + wts_map1(j,i)=Asend(ij) + END DO + END DO + END IF + deallocate (Asend) + deallocate(Numlinks) +#endif +!----------------------------------------------------------------------- +! +! correct for situations where N/S pole not explicitly included in +! grid (i.e. as a grid corner point). if pole is missing from only +! one grid, need to correct only the area and centroid of that +! grid. if missing from both, do complete weight calculation. +! This is necessary only when integrating w.r.t. phi (longitude) +! +!----------------------------------------------------------------------- + + if (phi_or_theta .eq. 1) then + + !*** North Pole + weights(1) = pi2 + weights(2) = pi*pi + weights(3) = zero + weights(4) = pi2 + weights(5) = pi*pi + weights(6) = zero + + if (grid1_npole_cell /=0) then + grid1_area(grid1_npole_cell) = grid1_area(grid1_npole_cell) + & + weights(1) + grid1_centroid_lat(grid1_npole_cell) = + & grid1_centroid_lat(grid1_npole_cell) + weights(2) + grid1_centroid_lon(grid1_npole_cell) = + & grid1_centroid_lon(grid1_npole_cell) + weights(3) + endif + + if (grid2_npole_cell /=0) then + grid2_area(grid2_npole_cell) = grid2_area(grid2_npole_cell) + & + weights(num_wts+1) + grid2_centroid_lat(grid2_npole_cell) = + & grid2_centroid_lat(grid2_npole_cell) + + & weights(num_wts+2) + grid2_centroid_lon(grid2_npole_cell) = + & grid2_centroid_lon(grid2_npole_cell) + + & weights(num_wts+3) + endif + + if (grid1_npole_cell /= 0 .and. grid2_npole_cell /=0) then + call store_link_cnsrv(grid1_npole_cell, + & grid2_npole_cell, weights) + + grid1_frac(grid1_npole_cell) = grid1_frac(grid1_npole_cell) + & + weights(1) + grid2_frac(grid2_npole_cell) = grid2_frac(grid2_npole_cell) + & + weights(num_wts+1) + endif + + + !*** South Pole + weights(1) = pi2 + weights(2) = -pi*pi + weights(3) = zero + weights(4) = pi2 + weights(5) = -pi*pi + weights(6) = zero + + if (grid1_spole_cell /=0) then + grid1_area(grid1_spole_cell) = grid1_area(grid1_spole_cell) + & + weights(1) + grid1_centroid_lat(grid1_spole_cell) = + & grid1_centroid_lat(grid1_spole_cell) + weights(2) + grid1_centroid_lon(grid1_spole_cell) = + & grid1_centroid_lon(grid1_spole_cell) + weights(3) + endif + + if (grid2_spole_cell /=0) then + grid2_area(grid2_spole_cell) = grid2_area(grid2_spole_cell) + & + weights(num_wts+1) + grid2_centroid_lat(grid2_spole_cell) = + & grid2_centroid_lat(grid2_spole_cell) + + & weights(num_wts+2) + grid2_centroid_lon(grid2_spole_cell) = + & grid2_centroid_lon(grid2_spole_cell) + + & weights(num_wts+3) + endif + + if (grid1_spole_cell /= 0 .and. grid2_spole_cell /=0) then + call store_link_cnsrv(grid1_spole_cell, + & grid2_spole_cell, weights) + + grid1_frac(grid1_spole_cell) = grid1_frac(grid1_spole_cell) + & + weights(1) + grid2_frac(grid2_spole_cell) = grid2_frac(grid2_spole_cell) + & + weights(num_wts+1) + endif + endif + + + + if(is_master)print *, 'Grid sweeps completed' + + +!----------------------------------------------------------------------- +! +! finish centroid computation +! +!----------------------------------------------------------------------- + + call timer_start(3) + +C$OMP PARALLEL +C$OMP WORKSHARE + where (grid1_area /= zero) + grid1_centroid_lat = grid1_centroid_lat/grid1_area + grid1_centroid_lon = grid1_centroid_lon/grid1_area + end where +C$OMP END WORKSHARE + +C$OMP WORKSHARE + where (grid2_area /= zero) + grid2_centroid_lat = grid2_centroid_lat/grid2_area + grid2_centroid_lon = grid2_centroid_lon/grid2_area + end where +C$OMP END WORKSHARE +C$OMP END PARALLEL + + +!----------------------------------------------------------------------- +! +! include centroids in weights and normalize using destination +! area if requested +! +!----------------------------------------------------------------------- + +C$OMP PARALLEL DEFAULT(SHARED) NUM_THREADS(nthreads) +C$OMP& PRIVATE(n,grid1_add,grid2_add,nwgt,weights,norm_factor) + +C$OMP DO SCHEDULE(DYNAMIC) + + do n=1,num_links_map1 + grid1_add = grid1_add_map1(n) + grid2_add = grid2_add_map1(n) + do nwgt=1,num_wts + weights( nwgt) = wts_map1(nwgt,n) + if (num_maps > 1) then + weights(num_wts+nwgt) = wts_map2(nwgt,n) + endif + end do + + select case(norm_opt) + case (norm_opt_dstarea) + if (grid2_area(grid2_add) /= zero) then + if (luse_grid2_area) then + norm_factor = one/grid2_area_in(grid2_add) + else + norm_factor = one/grid2_area(grid2_add) + endif + else + norm_factor = zero + endif + case (norm_opt_frcarea) + if (grid2_frac(grid2_add) /= zero) then + if (luse_grid2_area) then + norm_factor = grid2_area(grid2_add)/ + & (grid2_frac(grid2_add)* + & grid2_area_in(grid2_add)) + else + norm_factor = one/grid2_frac(grid2_add) + endif + else + norm_factor = zero + endif + case (norm_opt_none) + norm_factor = one + end select + + wts_map1(1,n) = weights(1)*norm_factor + wts_map1(2,n) = (weights(2) - weights(1)* + & grid1_centroid_lat(grid1_add))* + & norm_factor + wts_map1(3,n) = (weights(3) - weights(1)* + & grid1_centroid_lon(grid1_add))* + & norm_factor + + if (num_maps > 1) then + select case(norm_opt) + case (norm_opt_dstarea) + if (grid1_area(grid1_add) /= zero) then + if (luse_grid1_area) then + norm_factor = one/grid1_area_in(grid1_add) + else + norm_factor = one/grid1_area(grid1_add) + endif + else + norm_factor = zero + endif + case (norm_opt_frcarea) + if (grid1_frac(grid1_add) /= zero) then + if (luse_grid1_area) then + norm_factor = grid1_area(grid1_add)/ + & (grid1_frac(grid1_add)* + & grid1_area_in(grid1_add)) + else + norm_factor = one/grid1_frac(grid1_add) + endif + else + norm_factor = zero + endif + case (norm_opt_none) + norm_factor = one + end select + + wts_map2(1,n) = weights(num_wts+1)*norm_factor + wts_map2(2,n) = (weights(num_wts+2) - weights(num_wts+1)* + & grid2_centroid_lat(grid2_add))* + & norm_factor + wts_map2(3,n) = (weights(num_wts+3) - weights(num_wts+1)* + & grid2_centroid_lon(grid2_add))* + & norm_factor + endif + + end do + +C$OMP END DO + +C$OMP END PARALLEL + + if(is_master)print *, 'Total number of links = ',num_links_map1 + +C$OMP PARALLEL +C$OMP WORKSHARE + where (grid1_area /= zero) grid1_frac = grid1_frac/grid1_area +C$OMP END WORKSHARE +C$OMP WORKSHARE + where (grid2_area /= zero) grid2_frac = grid2_frac/grid2_area +C$OMP END WORKSHARE +C$OMP END PARALLEL + + call timer_stop(3) + +!----------------------------------------------------------------------- +! +! perform some error checking on final weights +! +!----------------------------------------------------------------------- + + allocate(ref_area(grid1_size)) + allocate(reldiff(grid1_size)) + +C$OMP PARALLEL DEFAULT(SHARED) NUM_THREADS(nthreads) +C$OMP& PRIVATE(n, i, inext, beglat, beglon, endlat, endlon, weights) +C$OMP DO SCHEDULE(DYNAMIC) + + do n=1,grid1_size + if (grid1_area(n) < -.01 .and. is_master) then + print *,'Grid 1 area error: ',n,grid1_area(n) + endif + if ((grid1_centroid_lat(n) < -pih-.01 .or. + & grid1_centroid_lat(n) > pih+.01) .and. is_master) then + print *,'Grid 1 centroid lat error: ',n,grid1_centroid_lat(n) + endif + + ref_area(n) = 0.0 + do i = 1, grid1_corners + inext = 1 + mod(i,grid1_corners) + + beglat = grid1_corner_lat(i,n) + beglon = grid1_corner_lon(i,n) + endlat = grid1_corner_lat(inext,n) + endlon = grid1_corner_lon(inext,n) + + if ((phi_or_theta .eq. 1 .and. beglon .eq. endlon) .or. + & (phi_or_theta .eq. 2 .and. beglat .eq. endlat)) cycle + + call line_integral(phi_or_theta, weights, num_wts, beglon, + & endlon, beglat, endlat, grid1_center_lat(n), + & grid1_center_lon(n), grid1_center_lat(n), + & grid1_center_lon(n)) + + ref_area(n) = ref_area(n) + weights(1) + enddo + enddo +C$OMP END DO +C$OMP END PARALLEL + + +! Correct for polar cells + + if (phi_or_theta .eq. 1) then + + !*** North Pole + weights(1) = pi2 + + if (grid1_npole_cell /=0) then + ref_area(grid1_npole_cell) = ref_area(grid1_npole_cell) + & + weights(1) + endif + + !*** South Pole + weights(1) = pi2 + + if (grid1_spole_cell /=0) then + ref_area(grid1_spole_cell) = ref_area(grid1_spole_cell) + & + weights(1) + endif + + endif + + + ave_reldiff = 0.0 + max_reldiff = -1.0 + + do n = 1, grid1_size + if(ref_area(n).gt.0.0)then ! added May 21 2013 + reldiff(n) = abs(ref_area(n)-grid1_area(n))/abs(ref_area(n)) + endif + ave_reldiff = ave_reldiff + reldiff(n) + if (reldiff(n) > max_reldiff) then + max_reldiff = reldiff(n) + maxrd_cell = n + maxrd_area = grid1_area(n) + maxrd_true = ref_area(n) + endif + end do + + ave_reldiff = ave_reldiff/grid1_size + + if(is_master.and.l_test)then + print * + print * + print *,'Grid 1: Ave. rel. diff. in areas: ', + & ave_reldiff + print *,' rel. diff. = abs(area-refarea)/refarea' + print * + print *,'Grid 1: Max. rel. diff. in areas: ', + & max_reldiff + print *, 'Max rel. diff. is in cell ',maxrd_cell + print *, 'Computed Area: ', maxrd_area + print *, 'Reference Area: ',maxrd_true + print * + endif + + deallocate(ref_area, reldiff) + + + + allocate(ref_area(grid2_size)) + allocate(reldiff(grid2_size)) + +C$OMP PARALLEL DEFAULT(SHARED) NUM_THREADS(nthreads) +C$OMP& PRIVATE(n, i, inext, beglat, beglon, endlat, endlon, weights) +C$OMP DO SCHEDULE(DYNAMIC) + + do n=1,grid2_size + if (grid2_area(n) < -.01 .and. is_master) then + print *,'Grid 2 area error: ',n,grid2_area(n) + endif + if ((grid2_centroid_lat(n) < -pih-.01 .or. + & grid2_centroid_lat(n) > pih+.01) .and. is_master) then + print *,'Grid 2 centroid lat error: ',n,grid2_centroid_lat(n) + endif + + ref_area(n) = 0.0 + do i = 1, grid2_corners + inext = 1 + mod(i,grid2_corners) + + beglat = grid2_corner_lat(i,n) + beglon = grid2_corner_lon(i,n) + endlat = grid2_corner_lat(inext,n) + endlon = grid2_corner_lon(inext,n) + + if ((phi_or_theta .eq. 1 .and. beglon .eq. endlon) .or. + & (phi_or_theta .eq. 2 .and. beglat .eq. endlat)) cycle + + call line_integral(phi_or_theta, weights, num_wts, beglon, + & endlon, beglat, endlat, grid2_center_lat(n), + & grid2_center_lon(n), grid2_center_lat(n), + & grid2_center_lon(n)) + + ref_area(n) = ref_area(n) + weights(1) + enddo + enddo +C$OMP END DO +C$OMP END PARALLEL + + +! Correct for polar cells + + if (phi_or_theta .eq. 1) then + + !*** North Pole + weights(1) = pi2 + + if (grid2_npole_cell /=0) then + ref_area(grid2_npole_cell) = ref_area(grid2_npole_cell) + & + weights(1) + endif + + !*** South Pole + weights(1) = pi2 + + if (grid2_spole_cell /=0) then + ref_area(grid2_spole_cell) = ref_area(grid2_spole_cell) + & + weights(1) + endif + + endif + + + ave_reldiff = 0.0 + max_reldiff = -1.0 + + do n = 1, grid2_size + reldiff(n) = abs(ref_area(n)-grid2_area(n))/abs(ref_area(n)) + ave_reldiff = ave_reldiff + reldiff(n) + if (reldiff(n) > max_reldiff) then + max_reldiff = reldiff(n) + maxrd_cell = n + maxrd_area = grid2_area(n) + maxrd_true = ref_area(n) + endif + end do + + ave_reldiff = ave_reldiff/grid2_size + + if(is_master.and.l_test)then + print * + print *,'Grid 2: Ave. rel. diff. in areas: ', + & ave_reldiff + print *,' rel. diff. = abs(area-refarea)/refarea' + print * + print *,'Grid 2: Max. rel. diff. in areas: ', + & max_reldiff + print *, 'Max rel. diff. is in cell ',maxrd_cell + print *, 'Computed Area: ', maxrd_area + print *, 'Reference Area: ',maxrd_true + print * + endif + + deallocate(ref_area,reldiff) + + if(is_master.and.l_test)then + print *, 'Computed area = Area of cell computed by adding areas' + print *, ' of intersection with other cells' + print *, 'Reference area = Area of cell by direct integration' + print * + endif + + !*** + !*** In the following code, gridN_centroid_lat is being used to + !*** store running tallies of the cell areas - so it is a + !*** misnomer used to avoid allocation of a new variable + !*** + + grid1_centroid_lat = zero + grid2_centroid_lat = zero + icount=0 + +C$OMP PARALLEL DEFAULT(SHARED) NUM_THREADS(nthreads) +C$OMP& PRIVATE(n,grid1_add,grid2_add,nwgt,weights) +C$OMP DO SCHEDULE(DYNAMIC) + + do n=1,num_links_map1 + grid1_add = grid1_add_map1(n) + grid2_add = grid2_add_map1(n) + + do nwgt=1,num_wts + weights( nwgt) = wts_map1(nwgt,n) + if (num_maps > 1) then + weights(num_wts+nwgt) = wts_map2(nwgt,n) + endif + end do + +! count warnings about weights that will be excluded + if (grid2_frac(grid2_add).gt.frac_lowest .and. + & grid2_frac(grid2_add).lt.frac_highest .and. is_master) then + if ( (wts_map1(1,n) < wt_lowest) )then + icount=icount+1 +! print statements that were here have been moved to another routine... + endif + if (norm_opt /= norm_opt_none .and. wts_map1(1,n) > + & wt_highest)then + icount=icount+1 +! print statements that were here have been moved to another routine... + endif + endif +C$OMP CRITICAL + grid2_centroid_lat(grid2_add) = + & grid2_centroid_lat(grid2_add) + wts_map1(1,n) +C$OMP END CRITICAL + + if (num_maps > 1) then + if (wts_map2(1,n) < -.01 .and. is_master) then + print *,'Map 2 weight < 0 ',grid1_add,grid2_add, + & wts_map2(1,n) + endif + if (norm_opt /= norm_opt_none .and. wts_map2(1,n) > 1.01 + & .and. is_master) then + print *,'Map 2 weight > 1 ',grid1_add,grid2_add, + & wts_map2(1,n) + endif +C$OMP CRITICAL + grid1_centroid_lat(grid1_add) = + & grid1_centroid_lat(grid1_add) + wts_map2(1,n) +C$OMP END CRITICAL + endif + end do + +C$OMP END DO +C$OMP END PARALLEL + + if(icount.gt.0.and.is_master)then + print *,'We had problems in ',icount,' points.' + endif +! stop condition was here...has been moved to another routine... + + !*** + !*** If grid1 has masks, links between some cells of grid1 and + !*** grid2 do not exist even though they overlap. In such a case, + !*** the following code will generate errors even though nothing + !*** is wrong (grid1_centroid_lat or grid2_centroid_lat are never + !*** updated in the above loop) + !*** + + do n=1,grid2_size + select case(norm_opt) + case (norm_opt_dstarea) + norm_factor = grid2_frac(n) + case (norm_opt_frcarea) + norm_factor = one + case (norm_opt_none) + if (luse_grid2_area) then + norm_factor = grid2_area_in(n) + else + norm_factor = grid2_area(n) + endif + end select +! if (abs(grid2_centroid_lat(n)-norm_factor) > .01 +! & .and. is_master) then +! print *,'Warning: sum of wts for map1 ',n, +! & grid2_centroid_lat(n),norm_factor +! endif +! write(501,*)n,grid2_centroid_lat(n) + end do + + + if (num_maps > 1) then + do n=1,grid1_size + select case(norm_opt) + case (norm_opt_dstarea) + norm_factor = grid1_frac(n) + case (norm_opt_frcarea) + norm_factor = one + case (norm_opt_none) + if (luse_grid1_area) then + norm_factor = grid1_area_in(n) + else + norm_factor = grid1_area(n) + endif + end select + if (abs(grid1_centroid_lat(n)-norm_factor) > .01 + & .and. is_master) then + print *,'Error: sum of wts for map2 ',n, + & grid1_centroid_lat(n),norm_factor + endif + end do + endif +!----------------------------------------------------------------------- + + call timer_stop(4) + + if(is_master)print *, 'Finished Conservative Remapping' + + if(l_test)then + call timer_print(1) + call timer_print(2) + call timer_print(3) + call timer_print(4) + endif + + end subroutine remap_conserv + +!*********************************************************************** + + + +!*********************************************************************** + + subroutine cellblock_integrate(ibegin, iend, grid_num, + & phi_or_theta) + + integer (SCRIP_i4) :: ibegin, iend, grid_num, phi_or_theta + + integer (SCRIP_i4) :: cell_add + + + do cell_add = ibegin, iend + + call cell_integrate(cell_add, grid_num, phi_or_theta) + + enddo + + + + end subroutine cellblock_integrate + +!*********************************************************************** + + + +!*********************************************************************** + + subroutine cell_integrate(cell_add, grid_num, phi_or_theta) + +!----------------------------------------------------------------------- +! +! Integrate around cell while finding intersecting with opposite +! grid cells and finding segments of cell boundary lying in cells +! of opposite grid +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! Input variables +! +!----------------------------------------------------------------------- + + integer (SCRIP_i4) :: + & cell_add, ! cell to be processed + & grid_num, ! grid that the cell belongs to + & phi_or_theta ! Integration var : + ! phi (lon) or theta (lat) + + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (SCRIP_i4), parameter :: + & max_subseg = 500 ! max number of subsegments per segment + ! to prevent infinite loop + + + integer (SCRIP_i4) :: + & i, inext, ! + & j, jnext, ! generic counters + & ic, k, ns, ! + & n, next_n, ! + & nwgt, it, ! + & oppcell_add, ! Cell from opposite grid we are + ! intersecting + & opp_grid_num, ! Index of opposite grid (2,1) + & min_add, ! addresses for restricting search of + & max_add, ! destination grid + & corner, ! corner of cell that segment starts + ! from + & next_corn, ! corner of cell that segment ends on + & nseg, ! number of segments to use to represent + ! edges near the pole + & num_subseg, ! number of subsegments + & bedgeid1, ! + & bedgeid2, ! ID of edge that a point is on + & bedgeid3, ! + & intedge, ! ID of intersected edge + & last_add, ! Address of last cell we were in + & next_add, ! Address of next cell we will go into + & adj_add ! Address of cell adjacent to current + ! one + + logical (SCRIP_logical) :: + & lcoinc, ! Are segments coincident? + & lrevers, ! Are we integrating segment in reverse? + & lboundary1, + & lboundary2, ! Is point is on cell boundary? + & lboundary3, + & last_lboundary, ! Is last point is on cell bdry? + & loutside, ! Is point outside the grid? + & lthresh, ! Has segment crossed threshold? + & srch_success, ! Was search for segment start + ! successful? + & intrsct_success, ! Was intersection of segment with + ! opposite grid successful? + & inpoly, ! Is point is in polygon + & last_endpt_inpoly, ! Was end point of last segment in cell + & last_endpt_onedge, ! Was end point of last segment on edge + ! of cell + & lstuck, ! Is the walk stuck inside a cell + & seg_outside, ! Is segment completely outside the grid + & bndedge, ! Is segment on the boundary of the grid + & search, ! Do we have to search to locate point + ! in grid + & inpolar, ! Are we in the polar region? + & special_cell, ! Is this a special cell + ! (only 1 vtx at pole) + & L_exit_do ! Do we need to escape from infinite + ! loop? (NRL) + + real (SCRIP_r8) :: + & intrsct_lat, ! lat of next intersection point + & intrsct_lon, ! lon of next intersection point + & beglat, beglon, ! start point of current sub seg + & endlat, endlon, ! endpoint of current seg + ! (chg to endseg?) + & endlat1, endlon1, ! endpoint of current subseg + & norm_factor ! factor for normalizing wts + + real (SCRIP_r8), dimension(2) :: + & begseg ! begin lat/lon for full segment + + real (SCRIP_r8), dimension(6) :: + & weights, ! local wgt array + & rev_weights ! Weights for grid1 and grid2 flipped + + real (SCRIP_r8) :: + & vec1_lat, vec1_lon, ! vectors, products + & vec2_lat, vec2_lon, ! used in grid search + & vec1_len, dp, + & midlat, midlon, ! Midpoint of segment + & tmplat, tmplon, + & srchpt_lat, ! Search point (offset from seg. start) + & srchpt_lon, + & offset, delta, ! Offset and offset increase for search + & sinang2, ! Square of sine of angle b/w two + ! segments + & dist2, ! Square of distance b/w two points + & fullseg_len2, ! Square of full segment length + & partseg_len2, ! Square of length of segment integrated + ! so far + & fullseg_dlat, ! Lat diff of full segment endpoints + & fullseg_dlon, ! Lon diff of full segment endpoints + & prevlon, + & nextlon, + & pole_lat, + & cell_center_lat, + & cell_center_lon, + & oppcell_center_lat, + & oppcell_center_lon + + real (SCRIP_r8), dimension(:), allocatable :: + & cell_corner_lat, ! Local copies of cell coordinates + & cell_corner_lon, ! May be augmented for computational + ! reasons + & oppcell_corner_lat, + & oppcell_corner_lon + + integer (SCRIP_i4) :: + & ncorners, ! Number of corners in local copy of cell + & ncorners_opp, ! Number of corners in local copy of oppcell + & nalloc, ! Allocation for the cell_corner_* array + & nalloc_opp ! Allocation for the oppcell_corner_* array + + real (SCRIP_r8) :: + & tmpwt1, tmpwt2 + + integer (SCRIP_i4) :: + & ncorners_at_pole, + & previdx, + & nextidx + + + if (grid_num .eq. 1) then + + !*** + !*** Set up a local copy of the cell with room to add + !*** degenerate edges + !*** + + ncorners = grid1_corners + nalloc = min(ncorners + 2, + & size(grid1_corner_lat(:,1))) + allocate (cell_corner_lat(nalloc), + & cell_corner_lon(nalloc)) + + do corner = 1, ncorners + cell_corner_lat(corner) = grid1_corner_lat(corner,cell_add) + cell_corner_lon(corner) = grid1_corner_lon(corner,cell_add) + enddo + + cell_center_lat = grid1_center_lat(cell_add) + cell_center_lon = grid1_center_lon(cell_add) + + special_cell = special_polar_cell1(cell_add) + + + !*** + !*** Also, allocate storage for the cell from the opposite grid + !*** + + opp_grid_num = 2 + ncorners_opp = grid2_corners + nalloc_opp = ncorners_opp+2 + allocate (oppcell_corner_lat(nalloc_opp), + & oppcell_corner_lon(nalloc_opp)) + + else + + !*** + !*** Set up the cell info with room to add degenerate edges + !*** + + ncorners = grid2_corners + nalloc = min(ncorners + 2, + & size(grid2_corner_lat(:,1))) + allocate (cell_corner_lat(nalloc), + & cell_corner_lon(nalloc)) + + do corner = 1, ncorners + cell_corner_lat(corner) = grid2_corner_lat(corner,cell_add) + cell_corner_lon(corner) = grid2_corner_lon(corner,cell_add) + enddo + + cell_center_lat = grid2_center_lat(cell_add) + cell_center_lon = grid2_center_lon(cell_add) + + special_cell = special_polar_cell2(cell_add) + + !*** + !*** Also, allocate storage for the cell from the opposite grid + !*** + + opp_grid_num = 1 + ncorners_opp = grid1_corners + nalloc_opp = ncorners_opp + 2 + allocate (oppcell_corner_lat(nalloc_opp), + & oppcell_corner_lon(nalloc_opp)) + + endif + + if (special_cell) then + + !*** + !*** Special cell with only one corner at the pole Such cells + !*** can have an artificially extreme distortion of the edges + !*** when mapped to the Lambert projection because of the span + !*** of longitudes on the edges So we will augment such cells + !*** with degenerate edges at the pole so that the edges coming + !*** off the pole will actually have the same longitude values + !*** at both ends + !*** + !*** lon_p lon_p+ lon_p lon_p- + !*** pi/2 pi/2 pi/2 pi/2 + !*** * *--------*------* + !*** / \ | | + !*** / \ | | + !*** / \ | | + !*** * * * * + !*** lon_p+ lon_p- lon_p+ lon_p- + !*** lat_p+ lat_p- lat_p+ lat_p- + !*** + + call modify_polar_cell(ncorners,nalloc,cell_corner_lat, + & cell_corner_lon) + + endif + + !*** + !*** Cell info set up - Now process the cell + !*** + + do corner = 1, ncorners + next_corn = mod(corner,ncorners) + 1 + + !*** + !*** define endpoints of the current segment + !*** + + beglat = cell_corner_lat(corner) + beglon = cell_corner_lon(corner) + endlat = cell_corner_lat(next_corn) + endlon = cell_corner_lon(next_corn) + lrevers = .false. + + !*** + !*** if this is a constant-longitude segment, skip the rest + !*** since the line integral contribution will be zero. + !*** + + if ((phi_or_theta == 1 .and. endlon == beglon) .or. + & (phi_or_theta == 2 .and. endlat == beglat)) cycle + + !*** + !*** to ensure exact path taken during both + !*** sweeps, always integrate segments in the same + !*** direction (SW to NE). + !*** + + if ((endlat < beglat) .or. + & (endlat == beglat .and. endlon < beglon)) then + tmplat = beglat + beglat = endlat + endlat = tmplat + tmplon = beglon + beglon = endlon + endlon = tmplon + lrevers = .not. lrevers + endif + + !*** But if one of the segment ends is in the polar region, + !*** we want to start from that (makes some logic easier) + + if ((beglat < north_thresh .and. endlat > north_thresh) .or. + & (beglat > south_thresh .and. endlat < south_thresh)) + & then + tmplat = beglat + beglat = endlat + endlat = tmplat + tmplon = beglon + beglon = endlon + endlon = tmplon + lrevers = .not. lrevers + endif + + begseg(1) = beglat + begseg(2) = beglon + + fullseg_dlat = endlat-beglat + fullseg_dlon = endlon-beglon + if (fullseg_dlon > pi) fullseg_dlon = fullseg_dlon - pi2 + if (fullseg_dlon < -pi) fullseg_dlon = fullseg_dlon + pi2 + fullseg_len2 = fullseg_dlat*fullseg_dlat + + & fullseg_dlon*fullseg_dlon + + partseg_len2 = 0.0 + + !*** + !*** Is this an edge on the boundary of the grid or + !*** on the boundary of the active cells + !*** + +! Commented out by MD +! call find_adj_cell(cell_add, corner, grid_num, adj_add) +! if (grid_num .eq. 1) then +! if (adj_add .eq. 0 .or. .not. grid1_mask(adj_add)) then +! bndedge = .true. +! else +! bndedge = .false. +! endif +! else +! if (adj_add .eq. 0 .or. .not. grid2_mask(adj_add)) then +! bndedge = .true. +! else +! bndedge = .false. +! endif +! endif + + call find_adj_cell(cell_add, corner, grid_num, adj_add) + bndedge = .false. + if (grid_num .eq. 1) then + if (adj_add .eq. 0) then + bndedge = .true. + else + if (.not. grid1_mask(adj_add)) then + bndedge = .true. + endif + endif + else + if (adj_add .eq. 0) then + bndedge = .true. + else + if (.not. grid2_mask(adj_add)) then + bndedge = .true. + endif + endif + endif + + !*** + !*** integrate along this segment, detecting intersections + !*** and computing the line integral for each sub-segment + !*** + + if (beglat .gt. north_thresh .or. beglat .lt. south_thresh) + & then + nseg = npseg ! Use multiple subsegments near the pole + inpolar = .true. + else + nseg = 1 + inpolar = .false. + endif + + + last_add = 0 + last_lboundary = .false. + last_endpt_inpoly = .false. + last_endpt_onedge = .false. + next_add = 0 + search = .true. + ns = 1 + +! outer "do while" + + do while (beglat /= endlat .or. beglon /= endlon) + + L_exit_do=.false. !NRL + + if ((ns .eq. nseg) .or. (inpolar .eqv. .false.)) then + ! + ! Last subseg or out of the polar region + ! Go directly to end of segment + ! + endlat1 = endlat + endlon1 = endlon + else + endlat1 = begseg(1) + ns*(fullseg_dlat)/nseg + endlon1 = begseg(2) + ns*(fullseg_dlon)/nseg + endif + + num_subseg = 0 + +! inner "do while" + + do while (beglat /= endlat1 .or. beglon /= endlon1) + + !*** + !*** If we integrated to the end or just past it (due to + !*** numerical errors), we are done with this segment + !*** + +!NRL see notes below re: infinite "do while" loop + L_exit_do=.false. !NRL + if (partseg_len2 .ge. fullseg_len2) then + write(*,*)'partseg_len2 .ge. fullseg_len2' + write(*,*)'beglat,beglon = ',beglat,beglon + write(*,*)'endlat,endlon = ',endlat,endlon + write(*,*)'endlat1,endlon1 = ',endlat1,endlon1 + write(*,*)'exiting inner do while loop' + L_exit_do=.true. !NRL + exit + end if + + !****************************************************** + !*** Try to find which cell of the opposite grid this + !*** segment is starting in and where it is exiting this + !*** cell + !****************************************************** + + vec1_lat = endlat1-beglat + vec1_lon = endlon1-beglon + if (vec1_lon > pi) vec1_lon = vec1_lon - pi2 + if (vec1_lon < -pi) vec1_lon = vec1_lon + pi2 + vec1_len = sqrt(vec1_lat*vec1_lat+vec1_lon*vec1_lon) + vec1_lat = vec1_lat/vec1_len + vec1_lon = vec1_lon/vec1_len + + offset = 100.0*tiny + oppcell_add = 0 + delta = 10*tiny + intrsct_success = .false. + loutside = .false. + lstuck = .false. + lboundary1 = .false. + lboundary2 = .false. + lboundary3 = .false. + + do while (.not. intrsct_success) + + !************************************************* + !*** Find out which cell the segment starts in + !************************************************* + + srch_success = .false. + if (search) then + + !*** + !*** Offset the start point in ever increasing + !*** amounts until we are able to reliably locate + !*** the point in a cell of grid2. Inability to locate + !*** the point causes the offset amount to increase + + it = 0 + do while (.not. srch_success) + + srchpt_lat = beglat + offset*vec1_lat + srchpt_lon = beglon + offset*vec1_lon + + call locate_point(srchpt_lat, srchpt_lon, + & cell_add, grid_num, opp_grid_num, + & oppcell_add, lboundary1, bedgeid1) + + if (oppcell_add .eq. 0) then + loutside = .true. +! lcoinc added by MD + lcoinc = .false. + exit ! exit the search loop + else + if (oppcell_add .ne. last_add .or. lthresh) + & then + srch_success = .true. + else + offset = offset + delta + if (offset .ge. vec1_len) then + exit + endif + if (it .gt. 3) then + delta = 2.0*delta + it = 0 + endif + endif + endif + + it = it + 1 + enddo ! do while (.not. srch_success) + + else + if (last_endpt_inpoly) then + + !*** We know the grid cell the end of the last + !*** segment (which is the beginning of this + !*** segment) + + oppcell_add = last_add + lboundary1 = last_lboundary + + else if (next_add .ne. 0) then + + !*** We know the edge of the grid2 cell that the + !*** last segment intersected, so we move into + !*** the adjacent cell + + oppcell_add = next_add + lboundary1 = .true. + + endif + + srch_success = .true. + + endif + + !***************************************************** + !*** Find where the segment exits this cell, if at all + !***************************************************** + + if (srch_success) then + + !*** + !*** First setup local copy of oppcell with room for + !*** adding degenerate edges + !*** + + if (grid_num .eq. 1) then + ncorners_opp = grid2_corners + do i = 1, ncorners_opp + oppcell_corner_lat(i) = + & grid2_corner_lat(i,oppcell_add) + oppcell_corner_lon(i) = + & grid2_corner_lon(i,oppcell_add) + enddo + oppcell_center_lat = + & grid2_center_lat(oppcell_add) + oppcell_center_lon = + & grid2_center_lon(oppcell_add) + + special_cell = special_polar_cell2(oppcell_add) + else + ncorners_opp = grid1_corners + do i = 1, ncorners_opp + oppcell_corner_lat(i) = + & grid1_corner_lat(i,oppcell_add) + oppcell_corner_lon(i) = + & grid1_corner_lon(i,oppcell_add) + enddo + oppcell_center_lat = + & grid1_center_lat(oppcell_add) + oppcell_center_lon = + & grid1_center_lon(oppcell_add) + + special_cell = special_polar_cell1(oppcell_add) + endif + + if (special_cell) then + call modify_polar_cell(ncorners_opp, nalloc_opp, + & oppcell_corner_lat, oppcell_corner_lon) + endif + + !*** + !*** First see if the segment end is + !*** in the same cell + !*** + + call ptincell(endlat1,endlon1, oppcell_add, + & ncorners_opp, + & oppcell_corner_lat,oppcell_corner_lon, + & oppcell_center_lat,oppcell_center_lon, + & opp_grid_num,inpoly, + & lboundary2,bedgeid2) + + if (inpoly) then + intrsct_lat = endlat1 + intrsct_lon = endlon1 + intrsct_success = .true. + search = .false. + next_add = 0 + last_add = oppcell_add ! for next subseg + last_lboundary = lboundary2 + last_endpt_inpoly = .true. + + if (lboundary1 .and. lboundary2) then + + !*** This is a edge on the boundary of the + !*** active mesh and both of its endpoints + !*** are on the boundary of the containing + !*** cell. Check if the the segment is also + !*** on the boundary + + midlat = (beglat+endlat1)/2.0 + if (abs(beglon-endlon1) .ge. pi) then + midlon = (beglon+endlon1)/2.0 - pi + else + midlon = (beglon+endlon1)/2.0 + endif + + call ptincell(midlat,midlon, oppcell_add, + & ncorners_opp, + & oppcell_corner_lat, oppcell_corner_lon, + & oppcell_center_lat, oppcell_center_lon, + & opp_grid_num, inpoly, lboundary3, + & bedgeid3) + + if (inpoly .and. lboundary3) then + lcoinc = .true. + intedge = bedgeid3 + endif + + else + lcoinc = .false. + endif + + else + + !*** + !*** Do an intersection to find out where the + !*** segment exits the cell + !*** + + call intersection(cell_add,grid_num, + & beglat, beglon, endlat1, endlon1, + & begseg, + & bedgeid1, + & oppcell_add, ncorners_opp, + & oppcell_corner_lat, oppcell_corner_lon, + & opp_grid_num, + & intrsct_lat, intrsct_lon, intedge, + & sinang2, lcoinc, lthresh) + + if (intedge /= 0) then + intrsct_success = .true. + last_add = oppcell_add ! for next subseg + last_endpt_onedge = .true. + last_endpt_inpoly = .false. + last_lboundary = .true. + + if (.not. lthresh) then + call find_adj_cell(oppcell_add,intedge, + & opp_grid_num,next_add) + if (next_add .ne. 0) then + search = .false. + else + search = .true. + endif + else + search = .true. + endif + endif + + endif + + if (.not. intrsct_success) then + + !*** Offset point and try again + + search = .true. + delta = 2.0*delta + offset = offset + delta + if (offset .gt. vec1_len) then + + ! Punt - exit the intersection loop + + intrsct_lat = endlat1 + intrsct_lon = endlon1 + last_add = 0 + last_lboundary = .false. + exit + + endif + endif + +!NRL if (lcoinc .and. .not. bndedge) then + + if (lcoinc .and. .not. bndedge !NRL + & .and. intedge /= 0) then !NRL + + !*** + !*** Segment is coincident with edge of other grid + !*** which means it could belong to one of 2 cells + !*** Choose the cell such that edge that is + !*** coincident with the segment is in the same + !*** dir as the segment + + i = intedge + inext = mod(i,ncorners_opp)+1 + vec2_lat = oppcell_corner_lat(inext) - + & oppcell_corner_lat(i) + vec2_lon = oppcell_corner_lon(inext) - + & oppcell_corner_lon(i) + + if (vec2_lon > pi) vec2_lon = vec2_lon - pi2 + if (vec2_lon < -pi) vec2_lon = vec2_lon + pi2 + + dp = vec1_lat*vec2_lat + vec1_lon*vec2_lon + + if ((.not. lrevers .and. dp .lt. 0) .or. + & (lrevers .and. dp .gt. 0)) then + + !*** Integrals from this segment must be + !*** assigned to the adjacent cell of + !*** opcell_add but only if such an adjacent + !*** cell exists + + call find_adj_cell(oppcell_add, intedge, + & opp_grid_num, adj_add) + + if (adj_add .gt. 0) then + oppcell_add = adj_add + + if (grid_num .eq. 1) then + ncorners_opp = grid2_corners + do i = 1, ncorners_opp + oppcell_corner_lat(i) = + & grid2_corner_lat(i,oppcell_add) + oppcell_corner_lon(i) = + & grid2_corner_lon(i,oppcell_add) + enddo + oppcell_center_lat = + & grid2_center_lat(oppcell_add) + oppcell_center_lon = + & grid2_center_lon(oppcell_add) + + special_cell = + & special_polar_cell2(oppcell_add) + else + ncorners_opp = grid1_corners + do i = 1, ncorners_opp + oppcell_corner_lat(i) = + & grid1_corner_lat(i,oppcell_add) + oppcell_corner_lon(i) = + & grid1_corner_lon(i,oppcell_add) + enddo + oppcell_center_lat = + & grid1_center_lat(oppcell_add) + oppcell_center_lon = + & grid1_center_lon(oppcell_add) + + special_cell = + & special_polar_cell1(oppcell_add) + endif + + if (special_cell) then + call modify_polar_cell(ncorners_opp, + & nalloc_opp, oppcell_corner_lat, + & oppcell_corner_lon) + endif + + endif + + endif + + endif + + else + + !*** + !*** Could not locate a viable cell for the segment + !*** start + !*** + + if (oppcell_add .eq. 0) then + loutside = .true. +! lcoinc added by MD + lcoinc = .false. + + !*** + !*** Take baby steps to see if any part of the + !*** segment is inside a cell of the other grid + !*** + + seg_outside = .false. + delta = vec1_len/100.00 + offset = delta + do while (.not. srch_success) + + srchpt_lat = beglat + offset*vec1_lat + srchpt_lon = beglon + offset*vec1_lon + + call locate_point(srchpt_lat, srchpt_lon, + & cell_add, grid_num, opp_grid_num, + & oppcell_add, lboundary1, bedgeid1) + + if (oppcell_add /= 0) then + srch_success = .true. + + !*** + !*** Found a point of the segment in the + !*** cell. Do a bisection method to find + !*** the starting point of the segment + !*** in the cell + !*** + + call converge_to_bdry(oppcell_add, + & opp_grid_num, ncorners_opp, + & oppcell_corner_lat, + & oppcell_corner_lon, + & oppcell_center_lat, + & oppcell_center_lon, + & srchpt_lat, srchpt_lon, + & beglat, beglon, + & intrsct_lat, intrsct_lon, + & bedgeid1) + + search = .false. + last_endpt_onedge = .true. + next_add = oppcell_add + last_lboundary = .true. + + oppcell_add = 0 + + else + + offset = offset + delta + + if (offset .ge. vec1_len) then +! print *, +! & 'Segment fully outside grid2' +! print *, 'Segment of grid1_add', +! & grid1_add +! print *, beglat,beglon +! print *, endlat1,endlon1 + + seg_outside = .true. + + intrsct_lat = endlat1 + intrsct_lon = endlon1 + + search = .true. + last_add = 0 + last_lboundary = .false. + + exit ! leave search loop + endif + endif + + enddo + + ! int. loop + if (srch_success .or. seg_outside) exit + + else + + if(is_master)then + print *, 'Unable to move out of last cell' + print *, 'Segment of edge ',corner, + & ' of grid cell ',cell_add + print *, 'Stuck in opposite grid cell ', + & oppcell_add + dist2 = + & (endlat1-begseg(1))*(endlat1-begseg(1)) + + & (endlon1-begseg(2))*(endlon1-begseg(2)) + print *, 'Fraction of segment left ', + & vec1_len/sqrt(dist2) + endif + lstuck = .true. + + !*** + !*** Punt - just assign the rest of the segment + !*** to the current cell it is stuck in by + !*** tagging the segment endpoint as the + !*** intersection point + !*** + + intrsct_lat = endlat1 + intrsct_lon = endlon1 + + search = .true. + last_add = 0 + last_lboundary = .false. + + endif + + exit ! exit the intersection loop + + endif ! if (srch_success) then ... else .... + + end do ! do while (.not. intrsct_success) + + !******************************************************** + !*** Compute the line integrals for this subsegment + !******************************************************** + + if (oppcell_add /= 0) then + call line_integral(phi_or_theta, weights, num_wts, + & beglon, intrsct_lon, beglat, intrsct_lat, + & cell_center_lat, cell_center_lon, + & oppcell_center_lat, oppcell_center_lon) + else + call line_integral(phi_or_theta, weights, num_wts, + & beglon, intrsct_lon, beglat, intrsct_lat, + & cell_center_lat, cell_center_lon, + & cell_center_lat, cell_center_lon) + endif + + !*** + !*** if integrating in reverse order, change + !*** sign of weights + !*** + + if (lrevers) then + weights = -weights + endif + + !*** + !*** store the appropriate addresses and weights. + !*** also add contributions to cell areas and centroids. + !*** + + if (grid_num .eq. 1) then + + if (oppcell_add /= 0) then + if (grid1_mask(cell_add)) then + call store_link_cnsrv(cell_add, oppcell_add, + & weights) + +C$OMP CRITICAL(block1) +! +! Could have another thread that found an intersection between that +! cell address and oppcell_add in which case it will try to write +! into this address - we have to block that until we are finished +! + grid1_frac(cell_add) = + & grid1_frac(cell_add) + weights(1) + + grid2_frac(oppcell_add) = + & grid2_frac(oppcell_add) + weights(num_wts+1) +C$OMP END CRITICAL(block1) + endif + + endif + +C$OMP CRITICAL(block2) + grid1_area(cell_add) = grid1_area(cell_add) + + & weights(1) + grid1_centroid_lat(cell_add) = + & grid1_centroid_lat(cell_add) + weights(2) + grid1_centroid_lon(cell_add) = + & grid1_centroid_lon(cell_add) + weights(3) +C$OMP END CRITICAL(block2) + + else + + !*** swap weights because in store_link_cnsrv + !*** we are always sending in grid1 weights first + !*** and then grid2 weights + + do i = 1, num_wts + rev_weights(num_wts+i) = weights(i) + rev_weights(i) = weights(num_wts+i) + enddo + + if (.not. lcoinc .and. oppcell_add /= 0) then + if (grid1_mask(oppcell_add)) then + call store_link_cnsrv(oppcell_add, cell_add, + & rev_weights) + +C$OMP CRITICAL(block3) +! +! Could have another thread that found an intersection between that +! cell address and oppcell_add in which case it will try to write +! into this address - we have to block that until we are finished +! + grid2_frac(cell_add) = + & grid2_frac(cell_add) + weights(1) + + grid1_frac(oppcell_add) = + & grid1_frac(oppcell_add) + weights(num_wts+1) +C$OMP END CRITICAL(block3) + + endif + + endif + +C$OMP CRITICAL(block4) + grid2_area(cell_add) = grid2_area(cell_add) + + & weights(1) + grid2_centroid_lat(cell_add) = + & grid2_centroid_lat(cell_add) + weights(2) + grid2_centroid_lon(cell_add) = + & grid2_centroid_lon(cell_add) + weights(3) +C$OMP END CRITICAL(block4) + endif + + !*** + !*** reset beglat and beglon for next subsegment. + !*** + + beglat = intrsct_lat + beglon = intrsct_lon + + !*** + !*** How far have we come from the start of the segment + !*** + + vec2_lat = intrsct_lat-begseg(1) + vec2_lon = intrsct_lon-begseg(2) + if (vec2_lon > pi) vec2_lon = vec2_lon - pi2 + if (vec2_lon < -pi) vec2_lon = vec2_lon + pi2 + + partseg_len2 = vec2_lat*vec2_lat + vec2_lon*vec2_lon + + !*** + !*** prevent infinite loops if integration gets stuck + !*** near cell or threshold boundary + !*** + + num_subseg = num_subseg + 1 + if (num_subseg > max_subseg) then + print *, + & 'integration stalled: num_subseg exceeded limit' + print *, 'Cell ',cell_add + print *, 'Edge ',corner + print *, 'Grid ',1 + dist2 = (endlat1-begseg(1))*(endlat1-begseg(1)) + + & (endlon1-begseg(2))*(endlon1-begseg(2)) + print *, 'Fraction of segment left ', + & vec1_len/sqrt(dist2) +! exit ! Give up and exit + stop ! Give up and stop + endif + +! inner "do while" + end do ! do while (beglat /= endlat1 ... + +!NRL We add an exit to outer do similar to exit of inner do: +!NRL This was an apparent bug: exit statement would escape +!NRL inner do but then computation could not get out of +!NRL outer do since beglat, beglon controlling outer do +!NRL never changed b/c it never gets to the part of the +!NRL code that changes beglat, beglon, b/c it keeps +!NRL exiting inner do. + +!NRL This should happen very rarely, so we have a print +!NRL statement to notify user. + + if (L_exit_do)then ! NRL + write(*,*)'partseg_len2,fullseg_len2 = ', ! NRL + & partseg_len2,fullseg_len2 ! NRL + write(*,*)'exiting outer do while loop' ! NRL + exit ! NRL + endif ! NRL + + ns = ns + 1 + if ((beglat > 0 .and. beglat < north_thresh) .or. + & (beglat < 0 .and. beglat > south_thresh)) + & then + inpolar = .false. + endif + +! outer "do while" + end do ! do while (beglat /= endlat .... + + call line_integral(phi_or_theta, weights, num_wts, + & begseg(2), endlon, begseg(1), endlat, + & cell_center_lat, + & cell_center_lon, + & cell_center_lat, + & cell_center_lon) + + !*** + !*** end of segment + !*** + + end do ! do corner=.... + + end subroutine cell_integrate +!*********************************************************************** + + +!*********************************************************************** + + subroutine modify_polar_cell(ncorners, nalloc, cell_corner_lat, + & cell_corner_lon) + + !*** Input variables + + integer (SCRIP_i4), intent(in) :: + & nalloc + + !*** In/Out Variables + + integer (SCRIP_i4), intent(inout) :: + & ncorners + real (SCRIP_r8), dimension(:), intent(inout) :: + & cell_corner_lat(nalloc), + & cell_corner_lon(nalloc) + + !*** Local variables + + integer (SCRIP_i4) :: + & npcorners, ! Number of polar corners + & pcorner, ! Index of the polar corner + ! (if only 1 is found) + & corner, ! Corner iterator variable + & previdx, ! Index of previous corner to polar corner + & nextidx ! Index of next corner to polar corner + + real (SCRIP_r8) :: + & pole_lat, ! Latitude considered to be pole + & prevlon, ! Latitude of previous corner to polar corner + & nextlon ! Latitude of next corner to polar corner + + + !*** + !*** Modify special cell with only one corner at the pole. Such + !*** cells can have an artificially extreme distortion of the + !*** edges when mapped to the Lambert projection because of the + !*** span of longitudes on the edges So we will augment such + !*** cells with degenerate edges at the pole so that the edges + !*** coming off the pole will actually have the same longitude + !*** values at both ends + !*** + !*** lon_p lon_p+ lon_p lon_p- + !*** pi/2 pi/2 pi/2 pi/2 + !*** * *--------*------* + !*** / \ | | + !*** / \ | | + !*** / \ | | + !*** * * * * + !*** lon_p+ lon_p- lon_p+ lon_p- + !*** lat_p+ lat_p- lat_p+ lat_p- + !*** + + + !*** + !*** MAJOR ASSUMPTION HERE IS THAT CELL_CORNER_LAT AND + !*** CELL_CORNER_LON HAVE ROOM TO GROW + !*** + if (ncorners .ge. nalloc) return ! ** * No room to grow + + pcorner = 0 + npcorners = 0 + do corner = 1, ncorners + if (abs(abs(cell_corner_lat(corner))-pih) .le. 1.0e-05) then + pcorner = corner + pole_lat = cell_corner_lat(corner) + npcorners = npcorners + 1 + endif + enddo + + + if (npcorners .ne. 1) return !*** Not the kind of cell we want + + previdx = mod((pcorner-1)-1+ncorners,ncorners) + 1 + prevlon = cell_corner_lon(previdx) + + nextidx = mod(pcorner,ncorners) + 1 + nextlon = cell_corner_lon(nextidx) + + !*** Move entries from pcorner+1 on back by one + + do corner = ncorners, pcorner+1, -1 + cell_corner_lat(corner+1) = cell_corner_lat(corner) + cell_corner_lon(corner+1) = cell_corner_lon(corner) + enddo + + !*** Add a corner after pcorner + + cell_corner_lat(pcorner+1) = pole_lat + cell_corner_lon(pcorner+1) = nextlon + + ncorners = ncorners+1 + + !*** Move entries from pcorner on back by one + + do corner = ncorners, pcorner, -1 + cell_corner_lat(corner+1) = cell_corner_lat(corner) + cell_corner_lon(corner+1) = cell_corner_lon(corner) + enddo + + !*** Add a corner before pcorner + + cell_corner_lat(pcorner) = pole_lat + cell_corner_lon(pcorner) = prevlon + + ncorners = ncorners+1 + + end subroutine modify_polar_cell + + +!*********************************************************************** + + subroutine intersection(seg_cell_id, seg_grid_id, + & beglat, beglon, endlat, endlon, begseg, begedge, + & cell_id, ncorners, cell_corner_lat, + & cell_corner_lon, cell_grid_id, intrsct_lat, intrsct_lon, + & intedge, sinang2, lcoinc, lthresh) + +!----------------------------------------------------------------------- +! +! this routine finds the intersection of a line segment given by +! beglon, endlon, etc. with a cell from another grid +! A coincidence flag is returned if the segment is entirely +! coincident with an edge of the opposite. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! intent(in): +! +!----------------------------------------------------------------------- + + integer (SCRIP_i4), intent(in) :: + & seg_cell_id ! ID of cell that intersecting segment is from + + integer (SCRIP_i4), intent(in) :: + & seg_grid_id ! ID of grid that intersecting segment is from + + real (SCRIP_r8), intent(in) :: + & beglat, beglon,! beginning lat/lon endpoints for segment + & endlat, endlon ! ending lat/lon endpoints for segment + + real (SCRIP_r8), dimension(2), intent(inout) :: + & begseg ! begin lat/lon of full segment + + integer (SCRIP_i4), intent(in) :: + & begedge ! edge that beginning point is on (can be 0) + + integer (SCRIP_i4), intent(in) :: + & cell_id ! cell to intersect with + + integer (SCRIP_i4), intent(in) :: + & ncorners ! number of corners of cell + + real (SCRIP_r8), dimension(ncorners), intent(in) :: + & cell_corner_lat, ! coordinates of cell corners + & cell_corner_lon + + integer (SCRIP_i4), intent(in) :: + & cell_grid_id ! which grid is the cell from? + + +!----------------------------------------------------------------------- +! +! intent(out): +! +!----------------------------------------------------------------------- + + real (SCRIP_r8), intent(out) :: + & intrsct_lat, + & intrsct_lon ! lat/lon coords of intersection + + real (SCRIP_r8), intent(out) :: + & sinang2 ! square of sine of angle between + ! intersecting lines + + integer (SCRIP_i4), intent(out) :: + & intedge ! edge that is intersected + + logical (SCRIP_logical), intent(out) :: + & lcoinc ! True if segment is coincident with + ! a cell edge + + logical (SCRIP_logical), intent(out) :: + & lthresh ! True if segment crosses threshold + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (SCRIP_i4) :: + & n, next_n + + logical (SCRIP_logical) :: + & found, first + + real (SCRIP_r8) :: + & lon1, lon2, ! local longitude variables for segment + & lat1, lat2, ! local latitude variables for segment + & grdlon1, grdlon2, ! local longitude variables for grid cell + & grdlat1, grdlat2, ! local latitude variables for grid cell + & vec1_lat, vec1_lon, + & vec2_lat, vec2_lon, ! + & vec3_lat, vec3_lon, ! vectors and vector products used + & cross_product, ! during grid search + & dot_product, ! + & lensqr1, lensqr2, ! + & lensqr3, ! + & s1, s2, determ, + & mat1, mat2, ! variables used for linear solve to + & mat3, mat4, ! find intersection + & rhs1, rhs2, ! + & denom, + & begsegloc(2), ! local copy of full segment start + & dist2, ! distance from start pt to intersection + ! pt + & maxdist2, ! max dist from start pt to any + ! intersection pt + & max_intrsct_lat, ! latitude of farthest intersection point + & max_intrsct_lon, ! longitude of farthest intersection + ! point + & minlat, maxlat, ! min and max latitudes of segment + & minlon, maxlon, ! min and max longitudes of segment + & tmplat, tmplon + + +!----------------------------------------------------------------------- +! +! initialize defaults, flags, etc. +! +!----------------------------------------------------------------------- + + lcoinc = .false. + lthresh = .false. + intedge = 0 + first = .true. + + lat1 = beglat + lon1 = beglon + lat2 = endlat + lon2 = endlon + + ! No edge is allowed to span more than pi radians + ! Accordingly transform one or the other end point + + if ((lon2-lon1) > pi) then + lon2 = lon2 - pi2 + else if ((lon2-lon1) < -pi) then + lon1 = lon1 - pi2 + endif + s1 = zero + +!----------------------------------------------------------------------- +! +! loop over sides of the cell to find intersection with side +! must check all sides for coincidences or intersections +! +!----------------------------------------------------------------------- + + if (beglat > north_thresh .or. beglat < south_thresh) then + + !*** Special intersection routine for cells near the pole + !*** Intersection is done in a transformed space using + !*** multi-segmented representation of the cell + + call pole_intersection(cell_id,ncorners, + & cell_corner_lat,cell_corner_lon,cell_grid_id, + & beglat, beglon, endlat, + & endlon, begseg, begedge, + & intedge,intrsct_lat,intrsct_lon, + & sinang2,lcoinc,lthresh) + + return + + endif + + + maxdist2 = -9999999.0 + + begsegloc(1) = begseg(1) + begsegloc(2) = begseg(2) + + lthresh = .false. + intrsct_loop: do n=1,ncorners + next_n = mod(n,ncorners) + 1 + + grdlat1 = cell_corner_lat(n) + grdlon1 = cell_corner_lon(n) + grdlat2 = cell_corner_lat(next_n) + grdlon2 = cell_corner_lon(next_n) + + lensqr2 = (grdlat1-grdlat2)*(grdlat1-grdlat2) + + & (grdlon1-grdlon2)*(grdlon1-grdlon2) + + if (lensqr2 .le. tiny*tiny) cycle ! degenerate edge + + ! No edge can span more than pi radians + + if (grdlon2-grdlon1 > pi) then + grdlon2 = grdlon2 - pi2 + else if (grdlon2-grdlon1 < -pi) then + grdlon1 = grdlon1 - pi2 + endif + + ! Also the two intersecting segments together + ! cannot span more than 2*pi radians + + minlon = min(lon1,lon2) + maxlon = max(grdlon1,grdlon2) + if (maxlon-minlon > pi2) then + grdlon1 = grdlon1 - pi2 + grdlon2 = grdlon2 - pi2 + else + minlon = min(grdlon1,grdlon2) + maxlon = max(lon1,lon2) + if (maxlon-minlon > pi2) then + grdlon1 = grdlon1 + pi2 + grdlon2 = grdlon2 + pi2 + endif + endif + + + !*** + !*** set up linear system to solve for intersection + !*** + + mat1 = lat2 - lat1 + mat2 = grdlat1 - grdlat2 + mat3 = lon2 - lon1 + mat4 = grdlon1 - grdlon2 + rhs1 = grdlat1 - lat1 + rhs2 = grdlon1 - lon1 + + determ = mat1*mat4 - mat2*mat3 + + !*** + !*** if the determinant is zero, the segments are either + !*** parallel or coincident. coincidences were detected + !*** above so do nothing. + + if (abs(determ) > tiny*tiny) then + + !*** if the determinant is non-zero, solve for the linear + !*** parameters s for the intersection point on each line + !*** segment. + !*** if 0= zero .and. s2 <= one .and. + & s1 > zero .and. s1 <= one) then + + !*** + !*** recompute intersection based on full segment + !*** so intersections are consistent for both sweeps + !*** + + if (lon2-begsegloc(2) > pi) then + lon2 = lon2 - pi2 + else if (lon2-begsegloc(2) < -pi) then + begsegloc(2) = begsegloc(2) - pi2 + endif + + + ! Also the two intersecting segments together + ! cannot span more than 2*pi radians + + minlon = min(begsegloc(2),lon2) + maxlon = max(grdlon1,grdlon2) + if (maxlon-minlon > pi2) then + grdlon1 = grdlon1 - pi2 + grdlon2 = grdlon2 - pi2 + else + minlon = min(grdlon1,grdlon2) + maxlon = max(begsegloc(2),lon2) + if (maxlon-minlon > pi2) then + grdlon1 = grdlon1 + pi2 + grdlon2 = grdlon2 + pi2 + endif + endif + + + mat1 = lat2 - begsegloc(1) + mat3 = lon2 - begsegloc(2) + rhs1 = grdlat1 - begsegloc(1) + rhs2 = grdlon1 - begsegloc(2) + + determ = mat1*mat4 - mat2*mat3 + + !*** + !*** sometimes due to roundoff, the previous + !*** determinant is non-zero, but the lines + !*** are actually coincident. if this is the + !*** case, skip the rest. + !*** + + if (determ /= zero) then + s1 = (rhs1*mat4 - mat2*rhs2)/determ + s2 = (mat1*rhs2 - rhs1*mat3)/determ + + intrsct_lat = begsegloc(1) + mat1*s1 + intrsct_lon = begsegloc(2) + mat3*s1 + + if (intrsct_lon < 0.0) then + intrsct_lon = intrsct_lon + pi2 + else if (intrsct_lon > pi2) then + intrsct_lon = intrsct_lon - pi2 + endif + + !*** + !*** Make sure the intersection point is not within + !*** tolerance of the starting point + !*** + + if (first) then + max_intrsct_lat = intrsct_lat + max_intrsct_lon = intrsct_lon + + vec1_lat = intrsct_lat-beglat + vec1_lon = intrsct_lon-beglon + if (vec1_lon > pi) then + vec1_lon = vec1_lon - pi2 + else if (vec1_lon < -pi) then + vec1_lon = vec1_lon + pi2 + endif + + maxdist2 = vec1_lat*vec1_lat + vec1_lon*vec1_lon + dist2 = maxdist2 + + denom = (mat1*mat1+mat2*mat2)*(mat3*mat3+mat4*mat4) + sinang2 = determ*determ/denom + intedge = n + first = .false. + else + vec1_lat = intrsct_lat-beglat + vec1_lon = intrsct_lon-beglon + if (vec1_lon > pi) then + vec1_lon = vec1_lon - pi2 + else if (vec1_lon < -pi) then + vec1_lon = vec1_lon + pi2 + endif + + dist2 = vec1_lat*vec1_lat + vec1_lon*vec1_lon + + if (dist2 > maxdist2) then + if (begedge .eq. 0 .or. begedge .ne. n) then + max_intrsct_lat = intrsct_lat + max_intrsct_lon = intrsct_lon + maxdist2 = dist2 + + denom = + & (mat1*mat1+mat2*mat2)*(mat3*mat3+mat4*mat4) + sinang2 = determ*determ/denom + intedge = n + endif + endif + endif + + else + print *, 'DEBUG: zero determ' + stop + endif + + endif + + else + + !*** + !*** Coincident lines or parallel lines + !*** + + cross_product = mat2*rhs2 - mat4*rhs1 + + !*** + !*** If area of triangle formed by endlat,endlon and + !*** the gridline is negligible then the lines are coincident + !*** + + + if (abs(cross_product) < tiny) then + + dot_product = mat1*(-mat2) + mat3*(-mat4) + + lensqr1 = mat1*mat1 + mat3*mat3 ! length sqrd of input + ! segment + + if (dot_product < zero) then + + !*** + !*** Segments oriented in the same direction + !*** + + + tmplat = grdlat2 + tmplon = grdlon2 + grdlat2 = grdlat1 + grdlon2 = grdlon1 + grdlat1 = tmplat + grdlon1 = tmplon + + endif + + + vec2_lat = grdlat1 - lat1 + vec2_lon = grdlon1 - lon1 + if (vec2_lon > pi) vec2_lon = vec2_lon - pi2 + if (vec2_lon < -pi) vec2_lon = vec2_lon + pi2 + + lensqr2 = vec2_lat*vec2_lat + vec2_lon*vec2_lon + + if (vec2_lat*mat1 + vec2_lon*mat3 < 0) then + lensqr2 = -lensqr2 + endif + + vec3_lat = grdlat2 - lat1 + vec3_lon = grdlon2 - lon1 + if (vec3_lon > pi) vec3_lon = vec3_lon - pi2 + if (vec3_lon < -pi) vec3_lon = vec3_lon + pi2 + + lensqr3 = (vec3_lat*vec3_lat+vec3_lon*vec3_lon) + + if (vec3_lat*mat1 + vec3_lon*mat3 < 0) then + lensqr3 = -lensqr3 + endif + + found = .false. + + if (lensqr2 > 0) then + if (lensqr2 <= lensqr1) then + intrsct_lat = grdlat1 + intrsct_lon = grdlon1 + found = .true. + endif + else + if (lensqr3 > 0) then + if (lensqr3 > lensqr1) then + intrsct_lat = lat2 + intrsct_lon = lon2 + found = .true. + else + intrsct_lat = grdlat2 + intrsct_lon = grdlon2 + found = .true. + endif + endif + endif + + if (found) then + + dist2 = (intrsct_lat-beglat)*(intrsct_lat-beglat)+ + & (intrsct_lon-beglon)*(intrsct_lon-beglon) + + !*** Coincidence intersection always wins + + max_intrsct_lat = intrsct_lat + max_intrsct_lon = intrsct_lon + maxdist2 = dist2 + sinang2 = 0 + intedge = n + lcoinc = .true. + + exit intrsct_loop + endif + + endif + + endif + + !*** restore lon1 and lon2 in case it got modified + + lon1 = beglon + lon2 = endlon + begsegloc(2) = begseg(2) + if ((lon2-lon1) > pi) then + lon2 = lon2 - pi2 + else if ((lon2-lon1) < -pi) then + lon1 = lon1 - pi2 + endif + + end do intrsct_loop + + if (intedge .eq. 0) then + return + else + if (maxdist2 < 1e6*tiny*tiny) then + intedge = 0 + return + else + intrsct_lat = max_intrsct_lat + intrsct_lon = max_intrsct_lon + endif + endif + +!----------------------------------------------------------------------- +! +! if the segment crosses a pole threshold, reset the intersection +! to be the threshold latitude. only check if this was not a +! threshold segment since sometimes coordinate transform can end +! up on other side of threshold again. +! +!----------------------------------------------------------------------- + + if (lthresh) then + if (intrsct_lat < north_thresh .or. intrsct_lat > south_thresh) + & lthresh = .false. + else if (lat1 > zero .and. intrsct_lat > north_thresh) then +! intrsct_lat = north_thresh + tiny + intrsct_lat = north_thresh + mat1 = lat2 - begsegloc(1) + mat3 = lon2 - begsegloc(2) + s1 = (intrsct_lat - begsegloc(1))/mat1 + intrsct_lon = begsegloc(2) + s1*mat3 + lthresh = .true. + else if (lat1 < zero .and. intrsct_lat < south_thresh) then +! intrsct_lat = south_thresh - tiny + intrsct_lat = south_thresh + mat1 = lat2 - begsegloc(1) + mat3 = lon2 - begsegloc(2) + s1 = (intrsct_lat - begsegloc(1))/mat1 + intrsct_lon = begsegloc(2) + s1*mat3 + lthresh = .true. + endif + + if (intrsct_lon < 0.0) then + intrsct_lon = intrsct_lon + pi2 + else if (intrsct_lon > pi2) then + intrsct_lon = intrsct_lon - pi2 + endif + + +!----------------------------------------------------------------------- + + end subroutine intersection + +!*********************************************************************** + + + subroutine pole_intersection(location,ncorners, + & cell_corners_lat,cell_corners_lon,cell_grid_id, + & beglat, beglon, endlat, endlon, begseg, begedge, + & intedge, intrsct_lat, intrsct_lon, + & sinang2, lcoinc, lthresh) + +!----------------------------------------------------------------------- +! +! Special intersection routine for line segment in cell close to +! poles +! A coordinate transformation (using a Lambert azimuthal +! equivalent projection) is performed to perform the intersection +! Also, since a straight line in lat-lon space is a curve in this +! transformed space, we represent each edge of the cell as having +! 'npseg' segments whose endpoints are mapped using the Lambert +! projection +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! intent(in): +! +!----------------------------------------------------------------------- + + integer (SCRIP_i4), intent(in) :: + & location ! cell to intersect segment with + + integer (SCRIP_i4), intent(in) :: + & ncorners ! Number of cell corners + + real (SCRIP_r8), dimension(ncorners), intent(in) :: + & cell_corners_lat, ! Cell corner coordinates + & cell_corners_lon + + integer (SCRIP_i4), intent(in) :: + & cell_grid_id ! which grid is the cell from? + + real (SCRIP_r8), intent(in) :: + & beglat, beglon, ! beginning lat/lon coords for segment + & endlat, endlon ! ending lat/lon coords for segment + + real (SCRIP_r8), dimension(2), intent(inout) :: + & begseg ! begin lat/lon of full segment + + integer (SCRIP_i4), intent(in) :: + & begedge ! edge on which segment start is on + ! (can be 0) + +!----------------------------------------------------------------------- +! +! intent(out): +! +!----------------------------------------------------------------------- + + integer (SCRIP_i4), intent(out) :: + & intedge ! Edge that segment intersects + + real (SCRIP_r8), intent(out) :: + & intrsct_lat, ! lat/lon coords of intersection + & intrsct_lon + + real (SCRIP_r8), intent(out) :: + & sinang2 ! square of sine of angle between + ! intersecting line segments + + logical (SCRIP_logical), intent(out) :: + & lcoinc ! True if segment is coincident with + ! a cell edge + + logical (SCRIP_logical), intent(inout) :: + & lthresh ! True if segment crosses threshold + + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (SCRIP_i4) :: + & n, n1, next_n, prev_n, + & it, i, j, + & ncorners2, + & intedge1 + + logical (SCRIP_logical) :: + & first, + & found + + real (SCRIP_r8) :: + & pi4, rns, ! north/south conversion + & x1, x2, ! local x variables for segment + & y1, y2, ! local y variables for segment + & grdx1, grdx2, ! local x variables for grid cell + & grdy1, grdy2, ! local y variables for grid cell + & grdlat1, grdlat2, ! latitude vars for grid cell + & grdlon1, grdlon2, ! longitude vars for grid cell + & vec1_y, vec1_x, ! + & vec2_y, vec2_x, ! vectors and cross products used + & vec3_y, vec3_x, ! + & vec1_lat, vec1_lon, ! + & vec2_lat, vec2_lon, ! + & vec3_lon, ! + & cross_product, ! + & dot_product, ! + & s1, s2, determ, ! variables used for linear solve to + & mat1, mat2, ! + & mat3, mat4, ! find intersection + & rhs1, rhs2, ! + & denom, ! + & intrsct_x, intrsct_y, ! intersection coordinates in + ! transformed space + & max_intrsct_lat, ! intersection point at max distance + & max_intrsct_lon, ! from the start point + & dist2, ! dist of intersection point from start + ! point + & maxdist2, ! max dist of intersection point from + ! start pnt + & lensqr1, lensqr2, ! various segment lengths + & lensqr3, + & tmpx, tmpy, + & tmplat, tmplon, + & ldummy + + !*** + !*** variables necessary if segment manages to hit pole + !*** + + real (SCRIP_r8), dimension(npseg*ncorners) :: + & cell_corners_lat_loc,! Lat/Lon coordinates of multi-segmented + & cell_corners_lon_loc ! version of cell + + + +!----------------------------------------------------------------------- +! +! initialize defaults, flags, etc. +! +!----------------------------------------------------------------------- + + max_intrsct_lat = pi ! intersection point at max distance + max_intrsct_lon = 4*pi ! from the start point + + intedge = 0 + first = .true. + maxdist2 = -999999.00 + + s1 = zero + +!----------------------------------------------------------------------- +! +! convert coordinates +! +!----------------------------------------------------------------------- + + if (beglat > zero) then + pi4 = quart*pi + rns = one + else + pi4 = -quart*pi + rns = -one + endif + + x1 = rns*two*sin(pi4 - half*beglat)*cos(beglon) + y1 = two*sin(pi4 - half*beglat)*sin(beglon) + x2 = rns*two*sin(pi4 - half*endlat)*cos(endlon) + y2 = two*sin(pi4 - half*endlat)*sin(endlon) + + intrsct_x = x2 + intrsct_y = y2 + + +!----------------------------------------------------------------------- +! +! now that a cell is found, search for the next intersection. +! loop over sides of the cell to find intersection with side +! must check all sides for coincidences or intersections +! +!----------------------------------------------------------------------- + + + if (abs(x1) .le. tiny .and. abs(y1) .le. tiny .and. + & abs(x2) .le. tiny .and. abs(y2) .le. tiny) then + + !*** + !*** The segment is a polar segment which is degenerate + !*** in the transformed Lambert space. Find out which + !*** cell edge it is coincident with and find the + !*** point where the segment exits this cell (if at all) + !*** NOTE 1: THIS MUST BE DONE IN LAT-LON SPACE + !*** NOTE 2: CODE RELEVANT ONLY FOR INTEGRATION W.R.T. phi + !*** + + intrsct_loop1: do n = 1, ncorners + next_n = mod(n,ncorners) + 1 + + grdlat1 = cell_corners_lat(n) + grdlon1 = cell_corners_lon(n) + grdlat2 = cell_corners_lat(next_n) + grdlon2 = cell_corners_lon(next_n) + grdx1 = rns*two*sin(pi4 - half*grdlat1)*cos(grdlon1) + grdy1 = two*sin(pi4 - half*grdlat1)*sin(grdlon1) + grdx2 = rns*two*sin(pi4 - half*grdlat2)*cos(grdlon2) + grdy2 = two*sin(pi4 - half*grdlat2)*sin(grdlon2) + + if (abs(grdx1) .le. tiny .and. abs(grdy1) .le. tiny .and. + & abs(grdx2) .le. tiny .and. abs(grdy2) .le. tiny) then + + !*** + !*** Found polar segment in cell + !*** + + vec1_lon = endlon-beglon + if (vec1_lon .gt. pi) vec1_lon = vec1_lon - pi2 + if (vec1_lon .lt. -pi) vec1_lon = vec1_lon + pi2 + + vec2_lon = grdlon2-grdlon1 + if (vec2_lon .gt. pi) vec2_lon = vec2_lon - pi2 + if (vec2_lon .lt. -pi) vec2_lon = vec2_lon + pi2 + + if (vec1_lon*vec2_lon .lt. 0) then + + !*** switch coordinates to simplify logic below + + tmplat = grdlat2 + tmplon = grdlon2 + grdlat2 = grdlat1 + grdlon2 = grdlon1 + grdlat1 = tmplat + grdlon1 = tmplon + endif + + vec2_lon = grdlon1 - beglon + if (vec2_lon .gt. pi) vec2_lon = vec2_lon - pi2 + if (vec2_lon .lt. -pi) vec2_lon = vec2_lon + pi2 + + vec3_lon = grdlon2 - beglon + if (vec3_lon .gt. pi) vec3_lon = vec3_lon - pi2 + if (vec3_lon .lt. -pi) vec3_lon = vec3_lon + pi2 + + found = .false. + + if (vec2_lon*vec1_lon > 0) then + if (abs(vec3_lon) < abs(vec1_lon)) then + intrsct_lon = grdlon2 + found = .true. + else if (abs(vec2_lon) < abs(vec1_lon)) then + intrsct_lon = grdlon1 ! Shouldn't be here + found = .true. + endif + else + if (vec3_lon*vec1_lon > 0) then + if (abs(vec3_lon) < abs(vec1_lon)) then + intrsct_lon = grdlon2 + found = .true. + endif + endif + + endif + + if (found) then + intrsct_lat = endlat + lcoinc = .true. + sinang2 = 0.0 + intedge = n + exit intrsct_loop1 + endif + + endif + + end do intrsct_loop1 + + return + endif + + + + + !**** + !**** General intersection + !**** + + + + !*** + !*** Construct multi-segmented version of the cell + !*** + + i = 0 + do n = ncorners, 1, -1 + i = i+1 + n1 = mod(n,ncorners)+1 + cell_corners_lat_loc(i) = cell_corners_lat(n1) + cell_corners_lon_loc(i) = cell_corners_lon(n1) + + prev_n = n1-1 + if (prev_n .eq. 0) prev_n = ncorners ! how do we do (j-1+n)%n + ! in F90 ? + + vec1_lat = cell_corners_lat(prev_n)-cell_corners_lat(n1) + vec1_lon = cell_corners_lon(prev_n)-cell_corners_lon(n1) + if (vec1_lon > pi) then + vec1_lon = vec1_lon - pi2 + else if (vec1_lon < -pi) then + vec1_lon = vec1_lon + pi2 + endif + + do j = 1, npseg-1 + i = i+1 + cell_corners_lat_loc(i) = + & cell_corners_lat(n1) + j*vec1_lat/npseg + cell_corners_lon_loc(i) = + & cell_corners_lon(n1) + j*vec1_lon/npseg + enddo + enddo + + ncorners2 = npseg*ncorners + + + + !*** + !*** Now intersect segment with multi-segmented version of cell + !*** + + + intrsct_loop2: do n= 1, ncorners2 + + next_n = mod(n,ncorners2) + 1 + + grdlat1 = cell_corners_lat_loc(n) + grdlon1 = cell_corners_lon_loc(n) + grdlat2 = cell_corners_lat_loc(next_n) + grdlon2 = cell_corners_lon_loc(next_n) + grdx1 = rns*two*sin(pi4 - half*grdlat1)*cos(grdlon1) + grdy1 = two*sin(pi4 - half*grdlat1)*sin(grdlon1) + grdx2 = rns*two*sin(pi4 - half*grdlat2)*cos(grdlon2) + grdy2 = two*sin(pi4 - half*grdlat2)*sin(grdlon2) + + if ((grdx1-grdx2)*(grdx1-grdx2)+(grdy1-grdy2)*(grdy1-grdy2) .le. + & tiny*tiny) cycle + + + !*** + !*** set up linear system to solve for intersection + !*** + + mat1 = x2 - x1 + mat2 = grdx1 - grdx2 + mat3 = y2 - y1 + mat4 = grdy1 - grdy2 + rhs1 = grdx1 - x1 + rhs2 = grdy1 - y1 + + determ = mat1*mat4 - mat2*mat3 + + !*** + !*** if the determinant is zero, the segments are either + !*** parallel or coincident or one segment has zero length. + + !*** if the determinant is non-zero, solve for the linear + !*** parameters s for the intersection point on each line + !*** segment. + !*** if 0 1.e-30) then + + s1 = (rhs1*mat4 - mat2*rhs2)/determ + s2 = (mat1*rhs2 - rhs1*mat3)/determ + + if (s2 >= zero .and. s2 <= one .and. + & s1 > tiny .and. s1 <= one) then + + intrsct_x = x1 + s1*mat1 + intrsct_y = y1 + s1*mat3 + + !*** + !*** convert back to lat/lon coordinates + !*** + + if (abs(intrsct_x) .gt. tiny .or. + & abs(intrsct_y) .gt. tiny) then + + intrsct_lon = rns*atan2(intrsct_y,intrsct_x) + + else + + !*** Degenerate case - we don't have a good way of + !*** finding out what the longitude corresponding + !*** to a (0,0) intersection is. So we take the + !*** the intersection as one of the two endpoints of + !*** the grid segment + + if (abs(abs(grdlat1)-pih) .lt. 1e-5 .and. + & abs(abs(grdlat2)-pih) .lt. 1e-5) then + + !*** Both endpoints of the grid segment are at the pole + !*** but at different longitudes + + vec1_lat = grdlat1-beglat + vec1_lon = grdlon1-beglon + if (vec1_lon > pi) then + vec1_lon = vec1_lon - pi2 + else if (vec1_lon < -pi) then + vec1_lon = vec1_lon + pi2 + endif + dist2 = vec1_lat*vec1_lat + vec1_lon*vec1_lon + + vec2_lat = grdlat2-beglat + vec2_lon = grdlon2-beglon + if (vec2_lon > pi) then + vec2_lon = vec2_lon - pi2 + else if (vec2_lon < -pi) then + vec2_lon = vec2_lon + pi2 + endif + + !*** pick the endpoint of the grid segment that is + !*** farthest from the beg point of the segment + + if ((vec1_lat*vec1_lat + vec1_lon*vec1_lon) .ge. + & (vec2_lat*vec2_lat + vec2_lon*vec2_lon)) then + intrsct_lon = grdlon1 + else + intrsct_lon = grdlon2 + endif + + else if (abs(abs(grdlat1)-pih) .lt. 1e-5) then + intrsct_lon = grdlon1 + else if (abs(abs(grdlat2)-pih) .lt. 1e-5) then + intrsct_lon = grdlon2 + endif + + !*** Make sure this longitude is not outside the + !*** beglon,endlon range + + vec1_lon = endlon-intrsct_lon + if (vec1_lon > pi) then + vec1_lon = vec1_lon - pi2 + else if (vec1_lon < -pi) then + vec1_lon = vec1_lon + pi2 + endif + + vec2_lon = beglon-intrsct_lon + if (vec2_lon > pi) then + vec2_lon = vec2_lon - pi2 + else if (vec2_lon < -pi) then + vec2_lon = vec2_lon + pi2 + endif + + !*** if vec1_lon and vec2_lon are of the same sign + !*** then intrsct_lon is outside the beglon,endlon + !*** range + + if (vec1_lon*vec2_lon > 0) cycle + + endif + + if (intrsct_lon < zero) + & intrsct_lon = intrsct_lon + pi2 + + if (abs(intrsct_x) > 1.d-10) then + intrsct_lat = (pi4 - + & asin(rns*half*intrsct_x/cos(intrsct_lon)))*two + ldummy = two*(pi4 - + & asin(sqrt(intrsct_x*intrsct_x+intrsct_y*intrsct_y)/2.)) + else if (abs(intrsct_y) > 1.d-10) then + intrsct_lat = (pi4 - + & asin(half*intrsct_y/sin(intrsct_lon)))*two + ldummy = two*(pi4 - + & asin(sqrt(intrsct_x*intrsct_x+intrsct_y*intrsct_y)/2.)) + else + intrsct_lat = two*pi4 + endif + + + !*** + !*** If there are multiple intersection points, accept the + !*** one that is not on the edge we started from but is + !*** closest to the start point - need this for + !*** intersection to work for non-convex edges + !*** + + if (first) then + + intedge1 = (n-1)/npseg + 1 + intedge1 = ncorners - intedge1 + 1 ! dir of edges was + ! reversed + if (intedge1 .ne. begedge) then + + max_intrsct_lat = intrsct_lat + max_intrsct_lon = intrsct_lon + + vec1_lat = intrsct_lat-beglat + vec1_lon = intrsct_lon-beglon + if (vec1_lon > pi) then + vec1_lon = vec1_lon - pi2 + else if (vec1_lon < -pi) then + vec1_lon = vec1_lon + pi2 + endif + maxdist2 = vec1_lat*vec1_lat + vec1_lon*vec1_lon + dist2 = maxdist2 + + denom = (mat1*mat1+mat2*mat2)*(mat3*mat3+mat4*mat4) + sinang2 = determ*determ/denom + intedge = intedge1 + + first = .false. + endif + + else + vec1_lat = intrsct_lat-beglat + vec1_lon = intrsct_lon-beglon + if (vec1_lon > pi) then + vec1_lon = vec1_lon - pi2 + else if (vec1_lon < -pi) then + vec1_lon = vec1_lon + pi2 + endif + dist2 = vec1_lat*vec1_lat + vec1_lon*vec1_lon + + !*** if the first intersection was on the same edge + !*** as the starting edge or + !*** the current intersection point is not on the + !*** starting edge and the distance to the beginning + !*** point is less than that of the previous + !*** intersection accept this intersection + + intedge1 = (n-1)/npseg + 1 + intedge1 = ncorners - intedge1 + 1 ! dir of edges was + ! reversed + if (dist2 > maxdist2) then + if (begedge == 0 .or. intedge1 .ne. begedge) then + max_intrsct_lat = intrsct_lat + max_intrsct_lon = intrsct_lon + maxdist2 = dist2 + + denom = + & (mat1*mat1+mat2*mat2)*(mat3*mat3+mat4*mat4) + sinang2 = determ*determ/denom + intedge = intedge1 + endif + endif + endif + endif + + else + + !*** + !*** Coincident lines or parallel lines + !*** + + cross_product = mat2*rhs2 - mat4*rhs1 + + if (abs(cross_product) < tiny) then + + dot_product = mat1*(-mat2) + mat3*(-mat4) + + !*** + !*** If area of triangle formed by x2,y2 and the gridline + !*** is negligible then the lines are coincident + !*** + + lensqr1 = mat1*mat1 + mat3*mat3 ! length sqrd of input + ! segment + + if (dot_product < zero) then + tmpx = grdx2 + tmpy = grdy2 + tmplat = grdlat2 + tmplon = grdlon2 + grdx2 = grdx1 + grdy2 = grdy1 + grdlat2 = grdlat1 + grdlon2 = grdlon1 + grdx1 = tmpx + grdy1 = tmpy + grdlat1 = tmplat + grdlon1 = tmplon + endif + + + vec2_x = grdx1 - x1 + vec2_y = grdy1 - y1 + lensqr2 = vec2_x*vec2_x + vec2_y*vec2_y + if (vec2_x*mat1+vec2_y*mat3 < 0) then + lensqr2 = -lensqr2 + endif + + + vec3_x = grdx2 - x1 + vec3_y = grdy2 - y1 + lensqr3 = (vec3_x*vec3_x+vec3_y*vec3_y) + if (vec3_x*mat1+vec3_y*mat3 < 0) then + lensqr3 = -lensqr3 + endif + + found = .false. + + if (lensqr2 > 0) then + if (lensqr2 <= lensqr1) then + intrsct_x = grdx1 + intrsct_y = grdy1 + intrsct_lat = grdlat1 + intrsct_lon = grdlon1 + found = .true. + endif + else + if (lensqr3 > 0) then + if (lensqr3 > lensqr1) then + intrsct_x = x2 + intrsct_y = y2 + intrsct_lat = endlat + intrsct_lon = endlon + found = .true. + else + intrsct_x = grdx2 + intrsct_y = grdy2 + intrsct_lat = grdlat2 + intrsct_lon = grdlon2 + found = .true. + endif + endif + endif + + if (found) then + dist2 = (intrsct_lat-beglat)*(intrsct_lat-beglat)+ + & (intrsct_lon-beglon)*(intrsct_lon-beglon) + + if (dist2 > tiny*tiny) then + + !*** Coincidence intersection always wins + + max_intrsct_lat = intrsct_lat + max_intrsct_lon = intrsct_lon + maxdist2 = dist2 + sinang2 = 0 + intedge = (n-1)/npseg + 1 + intedge = ncorners - intedge + 1 + lcoinc = .true. + + exit intrsct_loop2 + endif + endif + + + endif ! if (abs(cross_product) < tiny) + + endif ! if (abs(determ) > 1.e-30) .. else .. endif + + end do intrsct_loop2 + + if (maxdist2 < 1e6*tiny*tiny) then + intedge = 0 + return + else + intrsct_lat = max_intrsct_lat + intrsct_lon = max_intrsct_lon + endif + +!----------------------------------------------------------------------- +! +! if segment manages to cross over pole, shift the beginning +! endpoint in order to avoid hitting pole directly +! (it is ok for endpoint to be pole point) +! +!----------------------------------------------------------------------- + + if (abs(intrsct_x) < 1.e-10 .and. abs(intrsct_y) < 1.e-10 .and. + & (x2 /= zero .and. y2 /=0)) then + if (avoid_pole_count > 2) then + avoid_pole_count = 0 + avoid_pole_offset = 10.*avoid_pole_offset + endif + + cross_product = x1*(y2-y1) - y1*(x2-x1) + intrsct_lat = beglat + if (cross_product*intrsct_lat > zero) then + intrsct_lon = beglon + avoid_pole_offset + else + intrsct_lon = beglon - avoid_pole_offset + endif + + avoid_pole_count = avoid_pole_count + 1 + else + avoid_pole_count = 0 + avoid_pole_offset = tiny + endif + +!----------------------------------------------------------------------- +! +! if the segment crosses a pole threshold, reset the intersection +! to be the threshold latitude and do not reuse x,y intersect +! on next entry. only check if did not cross threshold last +! time - sometimes the coordinate transformation can place a +! segment on the other side of the threshold again +! +!----------------------------------------------------------------------- + + if (lthresh) then + if (intrsct_lat > north_thresh .or. intrsct_lat < south_thresh) + & lthresh = .false. + else if (beglat > zero .and. intrsct_lat < north_thresh) then + mat4 = endlat - begseg(1) + mat3 = endlon - begseg(2) + if (mat3 > pi) mat3 = mat3 - pi2 + if (mat3 < -pi) mat3 = mat3 + pi2 +! intrsct_lat = north_thresh - tiny + intrsct_lat = north_thresh + s1 = (north_thresh - begseg(1))/mat4 + intrsct_lon = begseg(2) + s1*mat3 + lthresh = .true. + else if (beglat < zero .and. intrsct_lat > south_thresh) then + mat4 = endlat - begseg(1) + mat3 = endlon - begseg(2) + if (mat3 > pi) mat3 = mat3 - pi2 + if (mat3 < -pi) mat3 = mat3 + pi2 +! intrsct_lat = south_thresh + tiny + intrsct_lat = south_thresh + s1 = (south_thresh - begseg(1))/mat4 + intrsct_lon = begseg(2) + s1*mat3 + lthresh = .true. + endif + + +!----------------------------------------------------------------------- + + end subroutine pole_intersection + +!*********************************************************************** + + + + subroutine line_integral(phi_or_theta, weights, num_wts, + & in_phi1, in_phi2, theta1, theta2, + & grid1_lat, grid1_lon, grid2_lat, grid2_lon) + +!----------------------------------------------------------------------- +! +! this routine computes the line integral of the flux function +! that results in the interpolation weights. the line is defined +! by the input lat/lon of the endpoints. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! intent(in): +! +!----------------------------------------------------------------------- + + integer (SCRIP_i4), intent(in) :: + & phi_or_theta ! Integration variable (lat or lon) + + integer (SCRIP_i4), intent(in) :: + & num_wts ! number of weights to compute + + real (SCRIP_r8), intent(in) :: + & in_phi1, in_phi2, ! longitude endpoints for the segment + & theta1, theta2, ! latitude endpoints for the segment + & grid1_lat, grid1_lon, ! reference coordinates for each + & grid2_lat, grid2_lon ! grid (to ensure correct 0,2pi interv. + +!----------------------------------------------------------------------- +! +! intent(out): +! +!----------------------------------------------------------------------- + + real (SCRIP_r8), dimension(2*num_wts), intent(out) :: + & weights ! line integral contribution to weights + + +! write(*,*)'subroutine line_integral' + if (phi_or_theta .eq. 1) then + call line_integral_phi(weights, num_wts, in_phi1, in_phi2, + & theta1, theta2, grid1_lat, grid1_lon, + & grid2_lat, grid2_lon) + else + call line_integral_theta(weights, num_wts,in_phi1,in_phi2, + & theta1, theta2, grid1_lat, grid1_lon, + & grid2_lat, grid2_lon) + endif + + + return + +!----------------------------------------------------------------------- + + end subroutine line_integral + +!*********************************************************************** + + + + subroutine line_integral_phi(weights, num_wts, + & in_phi1, in_phi2, theta1, theta2, + & grid1_lat, grid1_lon, grid2_lat, grid2_lon) + +!----------------------------------------------------------------------- +! +! this routine computes the line integral of the flux function +! that results in the interpolation weights. the line is defined +! by the input lat/lon of the endpoints. Integration is w.r.t. lon +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! intent(in): +! +!----------------------------------------------------------------------- + + integer (SCRIP_i4), intent(in) :: + & num_wts ! number of weights to compute + + real (SCRIP_r8), intent(in) :: + & in_phi1, in_phi2, ! longitude endpoints for the segment + & theta1, theta2, ! latitude endpoints for the segment + & grid1_lat, grid1_lon, ! reference coordinates for each + & grid2_lat, grid2_lon ! grid (to ensure correct 0,2pi interv. + +!----------------------------------------------------------------------- +! +! intent(out): +! +!----------------------------------------------------------------------- + + real (SCRIP_r8), dimension(2*num_wts), intent(out) :: + & weights ! line integral contribution to weights + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + real (SCRIP_r8) :: dphi, sinth1, sinth2, costh1, costh2, fac, + & phi1, phi2 + real (SCRIP_r8) :: f1, f2, fint + +!----------------------------------------------------------------------- +! +! weights for the general case based on a trapezoidal approx to +! the integrals. +! +!----------------------------------------------------------------------- + + +! write(*,*)'subroutine line_integral_phi' + + sinth1 = SIN(theta1) + sinth2 = SIN(theta2) + costh1 = COS(theta1) + costh2 = COS(theta2) + + dphi = in_phi1 - in_phi2 + if (dphi > pi) then + dphi = dphi - pi2 + else if (dphi < -pi) then + dphi = dphi + pi2 + endif + dphi = half*dphi + +!----------------------------------------------------------------------- +! +! the first weight is the area overlap integral. the second and +! fourth are second-order latitude gradient weights. +! +!----------------------------------------------------------------------- + + weights( 1) = dphi*(sinth1 + sinth2) + write(401,*)weights(1),' % A' + weights(num_wts+1) = dphi*(sinth1 + sinth2) + weights( 2) = dphi*(costh1 + costh2 + (theta1*sinth1 + + & theta2*sinth2)) + weights(num_wts+2) = dphi*(costh1 + costh2 + (theta1*sinth1 + + & theta2*sinth2)) + +!----------------------------------------------------------------------- +! +! the third and fifth weights are for the second-order phi gradient +! component. must be careful of longitude range. +! +!----------------------------------------------------------------------- + + f1 = half*(costh1*sinth1 + theta1) + f2 = half*(costh2*sinth2 + theta2) + + phi1 = in_phi1 - grid1_lon + if (phi1 > pi) then + phi1 = phi1 - pi2 + else if (phi1 < -pi) then + phi1 = phi1 + pi2 + endif + + phi2 = in_phi2 - grid1_lon + if (phi2 > pi) then + phi2 = phi2 - pi2 + else if (phi2 < -pi) then + phi2 = phi2 + pi2 + endif + + if ((phi2-phi1) < pi .and. (phi2-phi1) > -pi) then + weights(3) = dphi*(phi1*f1 + phi2*f2) + else + if (phi1 > zero) then + fac = pi + else + fac = -pi + endif + fint = f1 + (f2-f1)*(fac-phi1)/abs(dphi) + weights(3) = half*phi1*(phi1-fac)*f1 - + & half*phi2*(phi2+fac)*f2 + + & half*fac*(phi1+phi2)*fint + endif + + phi1 = in_phi1 - grid2_lon + if (phi1 > pi) then + phi1 = phi1 - pi2 + else if (phi1 < -pi) then + phi1 = phi1 + pi2 + endif + + phi2 = in_phi2 - grid2_lon + if (phi2 > pi) then + phi2 = phi2 - pi2 + else if (phi2 < -pi) then + phi2 = phi2 + pi2 + endif + + if ((phi2-phi1) < pi .and. (phi2-phi1) > -pi) then + weights(num_wts+3) = dphi*(phi1*f1 + phi2*f2) + else + if (phi1 > zero) then + fac = pi + else + fac = -pi + endif + fint = f1 + (f2-f1)*(fac-phi1)/abs(dphi) + weights(num_wts+3) = half*phi1*(phi1-fac)*f1 - + & half*phi2*(phi2+fac)*f2 + + & half*fac*(phi1+phi2)*fint + endif + +!----------------------------------------------------------------------- + + end subroutine line_integral_phi + +!*********************************************************************** + + + +!*********************************************************************** + + subroutine line_integral_theta(weights, num_wts, + & in_phi1, in_phi2, theta1, theta2, + & grid1_lat, grid1_lon, grid2_lat, grid2_lon) + +!----------------------------------------------------------------------- +! +! this routine computes the line integral of the flux function +! that results in the interpolation weights. the line is defined +! by the input lat/lon of the endpoints. Integration is w.r.t. lat +! +! Needed to use Simpson rule for this integration to get lower errors +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! intent(in): +! +!----------------------------------------------------------------------- + + integer (SCRIP_i4), intent(in) :: + & num_wts ! number of weights to compute + + real (SCRIP_r8), intent(in) :: + & in_phi1, in_phi2, ! longitude endpoints for the segment + & theta1, theta2, ! latitude endpoints for the segment + & grid1_lat, grid1_lon, ! reference coordinates for each + & grid2_lat, grid2_lon ! grid (to ensure correct 0,2pi interv. + +!----------------------------------------------------------------------- +! +! intent(out): +! +!----------------------------------------------------------------------- + + real (SCRIP_r8), dimension(2*num_wts), intent(out) :: + & weights ! line integral contribution to weights + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + real (SCRIP_r8) :: dtheta, dtheta2, costh1, costh2, costhpi, + & phi1, phi2, theta_pi, f1, f2, fpi, + & fm, costhm, part1, part2 + +!----------------------------------------------------------------------- +! +! weights for the general case based on a trapezoidal approx to +! the integrals. +! +!----------------------------------------------------------------------- + + costh1 = COS(theta1) + costh2 = COS(theta2) + costhm = COS(half*(theta1+theta2)) + + dtheta = theta2 - theta1 + dtheta2 = half*dtheta + +! write(*,*)' subroutine line_integral_theta' + + +!----------------------------------------------------------------------- +! +! Need to account for double value of longitude in calculations of +! all the weights. First we transform all the phis to be relative +! to the grid center This takes care of a good number of cases where +! the the phis span the periodic boundary in the longitudinal +! direction. If we still have a line that spans the periodic +! boundary then we have to integrate along the line in two parts - +! from point 1 to the periodic boundary and from the periodic +! boundary to the second point +! +! Example: Consider a line which has points at phi1 = -100 and phi2 +! = 100 degrees and say the grid center is at phi_c = 0 +! degrees. Then phi1-phi_c > -180 and phi2-phi_c < 180. But +! phi2-phi1 > 180. +! +! *********************************************!!!!!!!!!!! +! If we are doing the second step anyway, why are we normalizing the +! coordinates with respect to the grid centers? +! +! We need it particularly in this integration because phi figures +! explicitly in the expressions - so if a cell straddles the 0,2pi +! boundary, we integrate some edges with phi values close to zero +! and others with phi values close to 2pi leading to errors +! *********************************************!!!!!!!!!!! +! +!----------------------------------------------------------------------- + + phi1 = in_phi1 - grid1_lon + if (phi1 > pi) then + phi1 = phi1 - pi2 + else if (phi1 < -pi) then + phi1 = phi1 + pi2 + endif + + phi2 = in_phi2 - grid1_lon + if (phi2 > pi) then + phi2 = phi2 - pi2 + else if (phi2 < -pi) then + phi2 = phi2 + pi2 + endif + + f1 = phi1*costh1 + f2 = phi2*costh2 + + if ((phi2-phi1) < pi .and. (phi2-phi1) > -pi) then + + fm = half*(phi1+phi2)*costhm + + weights(1) = dtheta*(f1 + 4*fm + f2)/6.0 +! write(401,*)weights(1),' % A' + + weights(2) = dtheta2*(theta1*f1 + theta2*f2) + + weights(3) = half*dtheta2*(f1*f1 + f2*f2) + + else + if (phi1 > zero) then ! Means phi2-phi1 < -pi + +! theta at phi = pi + theta_pi = theta1 + (pi - phi1)*dtheta/(phi2 + pi2 - phi1) +! print *, '' +! print *, 'phi1',phi1,' phi2',phi2 +! print *, 'theta1',theta1,' theta2',theta2 +! print *, 'theta_pi',theta_pi + + costhpi = COS(theta_pi) + fpi = pi*costhpi + + fm = half*(phi1+pi)*cos(half*(theta1+theta_pi)) + part1 = (theta_pi - theta1)*(f1 + 4*fm + fpi)/6.0 + + fm = half*(phi2-pi)*cos(half*(theta1+theta_pi)) + part2 = 0.5*(theta2 - theta_pi)*(-fpi + 4*fm + f2)/6.0 + + weights(1) = part1 + part2 +! write(401,*)weights(1),' % B' + + part1 = 0.5*(theta_pi - theta1)*(theta1*f1 + theta_pi*fpi) + part2 = 0.5*(theta2 - theta_pi)*(-theta_pi*fpi + theta2*f2) + weights(2) = part1 + part2 + + + else ! Means phi2-phi1 > pi + +! theta at phi = -pi + theta_pi = theta1 + (-pi - phi1)*dtheta/(phi2 - pi2 - phi1) +! print *, '' +! print *, 'phi1',phi1,' phi2',phi2 +! print *, 'theta1',theta1,' theta2',theta2 +! print *, 'theta_pi',theta_pi + + costhpi = COS(theta_pi) + fpi = pi*costhpi + + fm = half*(phi1-pi)*cos(half*(theta1+theta_pi)) + part1 = 0.5*(theta_pi - theta1)*(f1 + 4*fm - fpi)/6.0 + + fm = half*(pi+phi2)*cos(half*(theta2+theta_pi)) + part2 = 0.5*(theta2 - theta_pi)*(fpi + 4*fm + f2)/6.0 + weights(1) = part1 + part2 +! write(401,*)weights(1),' % C' + + part1 = 0.5*(theta_pi - theta1)*(theta1*f1 - theta_pi*fpi) + part2 = 0.5*(theta2 - theta_pi)*(theta_pi*fpi + theta2*f2) + weights(2) = part1 + part2 + + + endif + + part1 = 0.25*(theta_pi - theta1)*(f1*f1 + fpi*fpi) + part2 = 0.25*(theta2 - theta_pi)*(fpi*fpi + f2*f2) + weights(3) = part1 + part2 + + endif + + + phi1 = in_phi1 - grid2_lon + if (phi1 > pi) then + phi1 = phi1 - pi2 + else if (phi1 < -pi) then + phi1 = phi1 + pi2 + endif + + phi2 = in_phi2 - grid2_lon + if (phi2 > pi) then + phi2 = phi2 - pi2 + else if (phi2 < -pi) then + phi2 = phi2 + pi2 + endif + + + f1 = phi1*costh1 + f2 = phi2*costh2 + + if ((phi2-phi1) < pi .and. (phi2-phi1) > -pi) then + + fm = half*(phi1+phi2)*costhm + + weights(num_wts+1) = dtheta2*(f1 + f2) + + weights(num_wts+2) = dtheta2*(theta1*f1 + theta2*f2) + + weights(num_wts+3) = half*dtheta2*(f1*f1 + f2*f2) + + else + if (phi1 > zero) then + + theta_pi = theta1 + (pi - phi1)*dtheta/(phi2 + pi2 - phi1) +! print *, '' +! print *, 'phi1',phi1,' phi2',phi2 +! print *, 'theta1',theta1,' theta2',theta2 +! print *, 'theta_pi',theta_pi + + costhpi = COS(theta_pi) + fpi = pi*costhpi + + fm = half*(phi1+pi)*cos(half*(theta1+theta_pi)) + part1 = (theta_pi - theta1)*(f1 + 4*fm + fpi)/6.0 + + fm = half*(-pi+phi2)*cos(half*(theta2+theta_pi)) + part2 = (theta2 - theta_pi)*(-fpi + 4*fm + f2)/6.0 + weights(num_wts+1) = part1 + part2 + + part1 = 0.5*(theta_pi - theta1)*(theta1*f1 + theta_pi*fpi) + part2 = 0.5*(theta2 - theta_pi)*(-theta_pi*fpi + theta2*f2) + weights(num_wts+2) = part1 + part2 + + + else + + theta_pi = theta1 + (-pi - phi1)*dtheta/(phi2 - pi2 - phi1) +! print *, '' +! print *, 'phi1',phi1,' phi2',phi2 +! print *, 'theta1',theta1,' theta2',theta2 +! print *, 'theta_pi',theta_pi + + costhpi = COS(theta_pi) + fpi = pi*costhpi + + fm = half*(phi1-pi)*cos(half*(theta1+theta_pi)) + part1 = (theta_pi - theta1)*(f1 +4*fm - fpi)/6.0 + + fm = half*(phi2+pi)*cos(half*(theta2+theta_pi)) + part2 = 0.5*(theta2 - theta_pi)*(fpi + 4*fm + f2)/6.0 + weights(num_wts+1) = part1 + part2 + + part1 = 0.5*(theta_pi - theta1)*(theta1*f1 - theta_pi*fpi) + part2 = 0.5*(theta2 - theta_pi)*(theta_pi*fpi + theta2*f2) + weights(num_wts+2) = part1 + part2 + + endif + + part1 = 0.25*(theta_pi - theta1)*(f1*f1 + fpi*fpi) + part2 = 0.25*(theta2 - theta_pi)*(fpi*fpi + f2*f2) + weights(num_wts+3) = part1 + part2 + + endif + +!----------------------------------------------------------------------- + + end subroutine line_integral_theta + +!*********************************************************************** + + + + subroutine store_link_cnsrv(add1, add2, weights) + +!----------------------------------------------------------------------- +! +! this routine stores the address and weight for this link in +! the appropriate address and weight arrays and resizes those +! arrays if necessary. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + integer (SCRIP_i4), intent(in) :: + & add1, ! address on grid1 + & add2 ! address on grid2 + + real (SCRIP_r8), dimension(:), intent(in) :: + & weights ! array of remapping weights for this link + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (SCRIP_i4) :: nlink, min_link, max_link ! link index + + logical (SCRIP_logical) :: found + + +!----------------------------------------------------------------------- +! +! if all weights are zero, do not bother storing the link +! +!----------------------------------------------------------------------- + + if (all(weights == zero)) return + +!----------------------------------------------------------------------- +! +! restrict the range of links to search for existing links +! +!----------------------------------------------------------------------- + +C$OMP CRITICAL(block5) +! first_call should be within critical block or else multiple +! threads will see it as true the first time around + + if (first_call_store_link_cnsrv) then + allocate(link_add1(2,grid1_size), link_add2(2,grid2_size)) + link_add1 = 0 + link_add2 = 0 + first_call_store_link_cnsrv = .false. + min_link = 1 + max_link = 0 + else + min_link = min(link_add1(1,add1),link_add2(1,add2)) + max_link = max(link_add1(2,add1),link_add2(2,add2)) + if (min_link == 0) then + min_link = 1 + max_link = 0 + endif + endif +C$OMP END CRITICAL(block5) + +!----------------------------------------------------------------------- +! +! if the link already exists, add the weight to the current weight +! arrays +! +!----------------------------------------------------------------------- + + found = .false. + + do nlink=min_link,max_link + if (add1 == grid1_add_map1(nlink)) then + if (add2 == grid2_add_map1(nlink)) then + +C$OMP CRITICAL(block3a) + wts_map1(:,nlink) = wts_map1(:,nlink) + weights(1:num_wts) + if (num_maps == 2) then + wts_map2(:,nlink) = wts_map2(:,nlink) + + & weights(num_wts+1:2*num_wts) + endif +C$OMP END CRITICAL(block3a) + found = .true. + exit + + endif + endif + end do + + + if (found) return + +!----------------------------------------------------------------------- +! +! if the link does not yet exist, increment number of links and +! check to see if remap arrays need to be increased to accomodate +! the new link. then store the link. +! +!----------------------------------------------------------------------- + +C$OMP CRITICAL(block6) + + num_links_map1 = num_links_map1 + 1 + if (num_links_map1 > max_links_map1) + & call resize_remap_vars(1,resize_increment) + + grid1_add_map1(num_links_map1) = add1 + grid2_add_map1(num_links_map1) = add2 + wts_map1 (:,num_links_map1) = weights(1:num_wts) + + if (num_maps > 1) then + num_links_map2 = num_links_map2 + 1 + if (num_links_map2 > max_links_map2) + & call resize_remap_vars(2,resize_increment) + + grid1_add_map2(num_links_map2) = add1 + grid2_add_map2(num_links_map2) = add2 + wts_map2 (:,num_links_map2) = weights(num_wts+1:2*num_wts) + endif + + if (link_add1(1,add1) == 0) link_add1(1,add1) = num_links_map1 + if (link_add2(1,add2) == 0) link_add2(1,add2) = num_links_map1 + link_add1(2,add1) = num_links_map1 + link_add2(2,add2) = num_links_map1 + +C$OMP END CRITICAL(block6) + +!----------------------------------------------------------------------- + + end subroutine store_link_cnsrv + +!*********************************************************************** + + + + + subroutine locate_segstart(cell_grid_num, cell, + & beglat, beglon, endlat, endlon, offset, + & srch_grid_num, cont_cell, lboundary, edgeid) + +!----------------------------------------------------------------------- +! +! Find the cell containing the given point +! +!----------------------------------------------------------------------- + + implicit none + +!----------------------------------------------------------------------- +! +! intent(in): +! +!----------------------------------------------------------------------- + + real (SCRIP_r8), intent(in) :: + & beglat, beglon, ! beginning and end points of segment + & endlat, endlon ! on which the point to be located lies + + real (SCRIP_r8), intent(in) :: + & offset ! Offset to calculate the search point + + integer (SCRIP_i4), intent(in) :: + & cell, ! Cell from which point originates + ! Point will be on boundary of orig_cell + & cell_grid_num ! Index of grid to which cell belongs + + integer (SCRIP_i4), intent(in) :: + & srch_grid_num ! num indicating if we are locating a + ! grid1 point in a cell of grid2 (num=2) + ! or a grid2 point in a cell of grid1 + ! (num=1) + +!----------------------------------------------------------------------- +! +! intent(out): +! +!----------------------------------------------------------------------- + + integer (SCRIP_i4), intent(out) :: + & cont_cell ! grid cell containing this point + + logical (SCRIP_logical), intent(out) :: + & lboundary ! flag points that lie on the boundary + ! of the cell + + integer (SCRIP_i4), intent(out) :: + & edgeid ! if point is on boundary, which local + ! edge is it on? (0 otherwise) + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (SCRIP_i4) :: i, j, k, n, ic + integer (SCRIP_i4) :: whichpole, srch_cell_add, + & grid1_add, grid2_add, min_add, max_add + + real (SCRIP_r8), dimension(:), allocatable :: + & cell_corner_x, cell_corner_y + + logical (SCRIP_logical) :: inpoly, latlon + + real (SCRIP_r8) :: + & vec1_x, vec1_y, vec1_lenx, vec1_lat, vec1_lon, vec1_len, + & begx, begy, endx, endy, ptx, pty, rns, pi4, ptlat, ptlon, + & lat, lon, cell_center_x, cell_center_y + +!----------------------------------------------------------------------- +! +! initialize defaults, flags, etc. +! +!----------------------------------------------------------------------- + + lboundary = .false. + edgeid = 0 + cont_cell = 0 + + + if (cell /= last_cell_locate_segstart .or. + & cell_grid_num /= last_cell_grid_num_locate_segstart + & .or. srch_grid_num /= last_srch_grid_num_locate_segstart) + & then + + last_cell_locate_segstart = cell + last_cell_grid_num_locate_segstart = cell_grid_num + last_srch_grid_num_locate_segstart = srch_grid_num + + if (first_call_locate_segstart) then + first_call_locate_segstart = .false. + last_cell_locate_segstart = 0 + last_cell_grid_num_locate_segstart = 0 + last_srch_grid_num_locate_segstart = 0 + num_srch_cells_locate_segstart = 0 + else + if (num_srch_cells_locate_segstart .gt. 0) then + deallocate(srch_add_locate_segstart, + & srch_corner_lat_locate_segstart, + & srch_corner_lon_locate_segstart, + & srch_center_lat_locate_segstart, + & srch_center_lon_locate_segstart) + endif + endif + + call get_srch_cells(cell, cell_grid_num, srch_grid_num, + & num_srch_cells_locate_segstart, srch_add_locate_segstart, + & srch_corners_locate_segstart, + & srch_corner_lat_locate_segstart, + & srch_corner_lon_locate_segstart, + & srch_center_lat_locate_segstart, + & srch_center_lon_locate_segstart) + + endif + + if (num_srch_cells_locate_segstart == 0) return + + + do ic=1,num_srch_cells_locate_segstart + + srch_cell_add = srch_add_locate_segstart(ic) + + + + !**** CAN WE ACCOMPLISH THE FOLLOWING THROUGH A SUBROUTINE + !**** CALLED SEGSTART_INCELL ?? + + + !*** IF POINT IS IN POLAR REGION, CHECK IN A TRANSFORMED SPACE + !*** HOWEVER, POINTS THAT ARE PRACTICALLY AT THE POLE CANNOT + !*** BE CORRECTLY LOCATED THIS WAY BECAUSE THE POLE IS A SINGULARITY + !*** AND CONTAINMENT IN ANY CELL INCIDENT ON THE POLE WILL GIVE US A + !*** POSITIVE ANSWER. FOR THESE POINTS REVERT TO THE LATLON SPACE + !*** + + + + vec1_lat = endlat-beglat + vec1_lon = endlon-beglon + if (vec1_lon > pi) then + vec1_lon = vec1_lon - pi2 + else if (vec1_lon < -pi) then + vec1_lon = vec1_lon + pi2 + endif + vec1_len = sqrt(vec1_lat*vec1_lat+vec1_lon*vec1_lon) + vec1_lat = vec1_lat/vec1_len + vec1_lon = vec1_lon/vec1_len + + ptlat = beglat + offset*vec1_lat + ptlon = beglon + offset*vec1_lon + + + if ((ptlat .gt. north_thresh .and. abs(ptlat-pih) .ge. 0.001) + & .or. + & (ptlat .lt. south_thresh .and. abs(ptlat+pih) .ge. 0.001)) + & then + + if (ptlat > zero) then + pi4 = quart*pi + rns = one + else + pi4 = -quart*pi + rns = -one + endif + + + begx = rns*two*sin(pi4 - half*beglat)*cos(beglon) + begy = two*sin(pi4 - half*beglat)*sin(beglon) + endx = rns*two*sin(pi4 - half*endlat)*cos(endlon) + endy = two*sin(pi4 - half*endlat)*sin(endlon) + + vec1_x = endx-begx + vec1_y = endy-begy + + vec1_lenx = sqrt(vec1_x*vec1_x + vec1_y*vec1_y) + vec1_x = vec1_x/vec1_lenx + vec1_y = vec1_y/vec1_lenx + + + !*** Must calculate ptx and pty as an offset on straight + !*** line in polar space rather than calculating it on a + !*** straight line in latlon space an offset point in latlon + !*** space will be off the straight line in polar space + + ptx = begx + offset*vec1_x + pty = begy + offset*vec1_y + + latlon = .false. + + ! Since we want greater fidelity for locating the points + ! we send in the mid-points of the polygon edges too + ! BUT THAT MAKES THE POLYGON NON-CONVEX SOMETIMES AND + ! THE CROSS-PRODUCT CHECK FAILS. SO USE CODE TO CHECK GENERAL + ! POLYGONS + + + allocate(cell_corner_x(npseg*srch_corners_locate_segstart), + & cell_corner_y(npseg*srch_corners_locate_segstart)) + + + k = 0 + do i = srch_corners_locate_segstart, 1, -1 + k = k+1 + lat = srch_corner_lat_locate_segstart(i,ic) + lon = srch_corner_lon_locate_segstart(i,ic) + cell_corner_x(k) = rns*two*sin(pi4-half*lat)*cos(lon) + cell_corner_y(k) = two*sin(pi4-half*lat)*sin(lon) + + j = i-1 + if (j .eq. 0) j = srch_corners_locate_segstart ! how do + ! we do (j-1+n)%n in F90? + + vec1_lat = srch_corner_lat_locate_segstart(j,ic) + & -srch_corner_lat_locate_segstart(i,ic) + vec1_lon = srch_corner_lon_locate_segstart(j,ic) + & -srch_corner_lon_locate_segstart(i,ic) + if (vec1_lon > pi) then + vec1_lon = vec1_lon - pi2 + else if (vec1_lon < -pi) then + vec1_lon = vec1_lon + pi2 + endif + + do j = 1, npseg-1 + k = k+1 + lat = srch_corner_lat_locate_segstart(i,ic) + & + j*vec1_lat/npseg + lon = srch_corner_lon_locate_segstart(i,ic) + & + j*vec1_lon/npseg + cell_corner_x(k) = rns*two*sin(pi4-half*lat)*cos(lon) + cell_corner_y(k) = two*sin(pi4-half*lat)*sin(lon) + enddo + enddo + + + call ptinpolygen2(ptx, pty, k, cell_corner_x, + & cell_corner_y, latlon, inpoly, lboundary, edgeid) + + if (lboundary) then + edgeid = (edgeid-1)/npseg + 1 ! convert from index in + ! multi-segmented to regular cell + endif + + deallocate(cell_corner_x, cell_corner_y) + + else + + latlon = .true. + + whichpole = 0 + if (srch_grid_num .eq. 1 .and. + & srch_cell_add .eq. grid1_spole_cell) then + + whichpole = -1 ! S pole + call ptinpolarpoly(ptlat, ptlon, + & srch_corners_locate_segstart, + & srch_corner_lat_locate_segstart(:,ic), + & srch_corner_lon_locate_segstart(:,ic), + & latlon, whichpole, inpoly, lboundary, edgeid) + + else if (srch_grid_num .eq. 1 .and. + & srch_cell_add .eq. grid1_npole_cell) then + + whichpole = 1 ! N pole + call ptinpolarpoly(ptlat, ptlon, + & srch_corners_locate_segstart, + & srch_corner_lat_locate_segstart(:,ic), + & srch_corner_lon_locate_segstart(:,ic), + & latlon, whichpole, inpoly, lboundary, edgeid) + + else if (srch_grid_num .eq. 2 .and. + & srch_cell_add .eq. grid2_spole_cell) then + + whichpole = -1 ! S pole + call ptinpolarpoly(ptlat, ptlon, + & srch_corners_locate_segstart, + & srch_corner_lat_locate_segstart(:,ic), + & srch_corner_lon_locate_segstart(:,ic), + & latlon, whichpole, inpoly, lboundary, edgeid) + + else if (srch_grid_num .eq. 2 .and. + & srch_cell_add .eq. grid2_npole_cell) then + + whichpole = 1 ! N pole + call ptinpolarpoly(ptlat, ptlon, + & srch_corners_locate_segstart, + & srch_corner_lat_locate_segstart(:,ic), + & srch_corner_lon_locate_segstart(:,ic), + & latlon, whichpole, inpoly, lboundary, edgeid) + + else + + !*** + !*** General cell + !*** + + call ptinpoly(ptlat, ptlon, srch_corners_locate_segstart, + & srch_corner_lat_locate_segstart(:,ic), + & srch_corner_lon_locate_segstart(:,ic), + & latlon, inpoly, lboundary, edgeid) + + endif + + endif + + if (inpoly) then + cont_cell = srch_cell_add + exit + endif + + end do + + return + +!---------------------------------------------------------------------- + + end subroutine locate_segstart + +!********************************************************************** + + + + +!********************************************************************** + + subroutine locate_point(ptlat, ptlon, cell, cell_grid_num, + & srch_grid_num, cont_cell, lboundary, edgeid) + +!----------------------------------------------------------------------- +! +! Find the cell containing the given point +! +!----------------------------------------------------------------------- + + implicit none + +!----------------------------------------------------------------------- +! +! intent(in): +! +!----------------------------------------------------------------------- + + real (SCRIP_r8), intent(in) :: + & ptlat, ptlon ! Point to locate + + integer (SCRIP_i4), intent(in) :: + & cell, ! Cell from which point originates + ! Point will be on boundary of orig_cell + & cell_grid_num ! Index of grid to which cell belongs + + integer (SCRIP_i4), intent(in) :: + & srch_grid_num ! num indicating if we are locating a + ! grid1 point in a cell of grid2 (num=2) + ! or a grid2 point in a cell of grid1 + ! (num=1) + +!----------------------------------------------------------------------- +! +! intent(out): +! +!----------------------------------------------------------------------- + + integer (SCRIP_i4), intent(out) :: + & cont_cell ! grid cell containing this point + + logical (SCRIP_logical), intent(out) :: + & lboundary ! flag points that lie on the boundary + ! of the cell + + integer (SCRIP_i4), intent(out) :: + & edgeid ! if point is on boundary, which local + ! edge is it on? (0 otherwise) + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (SCRIP_i4) :: i, j, n, ic + integer (SCRIP_i4) :: whichpole, srch_cell_add, + & grid1_add, grid2_add, min_add, max_add, + & previdx, nextidx, pcorner, corner, + & ncorners, nalloc + + real (SCRIP_r8), dimension(:), allocatable :: + & cell_corner_lat, + & cell_corner_lon + + real (SCRIP_r8) :: + & prevlon, + & nextlon, + & polelat, + & cell_center_lat, + & cell_center_lon + + + logical (SCRIP_logical) :: inpoly, latlon + logical (SCRIP_logical) :: test + +!----------------------------------------------------------------------- +! +! initialize defaults, flags, etc. +! +!----------------------------------------------------------------------- + + lboundary = .false. + edgeid = 0 + cont_cell = 0 + + if (cell /= last_cell_locate_point .or. cell_grid_num /= + & last_cell_grid_num_locate_point + & .or. srch_grid_num /= last_srch_grid_num_locate_point) then + + last_cell_locate_point = cell + last_cell_grid_num_locate_point = cell_grid_num + last_srch_grid_num_locate_point = srch_grid_num + + if (first_call_locate_point) then + first_call_locate_point = .false. + last_cell_locate_point = 0 + last_cell_grid_num_locate_point = 0 + last_srch_grid_num_locate_point = 0 + num_srch_cell_locate_points = 0 + else + if (num_srch_cell_locate_points .gt. 0) then + deallocate(srch_add_locate_point, + & srch_corner_lat_locate_point, + & srch_corner_lon_locate_point) + endif + endif + + call get_srch_cells(cell, cell_grid_num, srch_grid_num, + & num_srch_cell_locate_points, srch_add_locate_point, + & srch_corners_locate_point, + & srch_corner_lat_locate_point,srch_corner_lon_locate_point, + & srch_center_lat_locate_point,srch_center_lon_locate_point) + + endif + + if (num_srch_cell_locate_points == 0) return + + + ncorners = srch_corners_locate_point + nalloc = ncorners+2 + allocate(cell_corner_lat(nalloc), + & cell_corner_lon(nalloc)) + + + do ic=1,num_srch_cell_locate_points + + srch_cell_add = srch_add_locate_point(ic) + + do i = 1, ncorners + cell_corner_lat(i) = srch_corner_lat_locate_point(i,ic) + cell_corner_lon(i) = srch_corner_lon_locate_point(i,ic) + enddo + + cell_center_lat = srch_center_lat_locate_point(ic) + cell_center_lon = srch_center_lon_locate_point(ic) + +! if ((srch_grid_num .eq. 1 .and. +! & (special_polar_cell1(srch_cell_add))) .or. +! & (srch_grid_num .eq. 2 .and. +! & (special_polar_cell2(srch_cell_add)))) then +! +! Modified by MD + test=.false. + if (srch_grid_num .eq. 1) then + if (special_polar_cell1(srch_cell_add)) then + test=.true. + endif + else + if (special_polar_cell2(srch_cell_add)) then + test=.true. + endif + endif + if (test) then + call modify_polar_cell(ncorners, nalloc, cell_corner_lat, + & cell_corner_lon) + + endif + + call ptincell(ptlat, ptlon, srch_cell_add, ncorners, + & cell_corner_lat, cell_corner_lon, + & cell_center_lat, cell_center_lon, + & srch_grid_num, inpoly, lboundary, edgeid) + + + if (inpoly) then + cont_cell = srch_cell_add + exit + endif + + ncorners = srch_corners_locate_point ! reset it for other srch + !cells + end do + +!---------------------------------------------------------------------- + + end subroutine locate_point + +!********************************************************************** + + + +!********************************************************************** + + subroutine ptincell(ptlat, ptlon, cell_add, ncorners, + & cell_corner_lat, cell_corner_lon, + & cell_center_lat, cell_center_lon, + & cell_grid_id, inpoly, lboundary, edgeid) + +!---------------------------------------------------------------------- + + implicit none + +!----------------------------------------------------------------------- +! +! intent(in): +! +!----------------------------------------------------------------------- + + real (SCRIP_r8), intent(in) :: + & ptlat, ptlon ! Point to locate + + integer (SCRIP_i4), intent(in) :: + & cell_add ! ID of cell + + integer (SCRIP_i4), intent(in) :: + & ncorners + + real (SCRIP_r8), dimension(ncorners), intent(in) :: + & cell_corner_lat, cell_corner_lon + + real (SCRIP_r8), intent(in) :: + & cell_center_lat, + & cell_center_lon + + integer (SCRIP_i4), intent(in) :: + & cell_grid_id ! num indicating if we are locating a grid1 + ! point in a cell of grid2 (num = 2) or + ! a grid2 point in a cell of grid1 (num = 1) + + +!----------------------------------------------------------------------- +! +! intent(out): +! +!----------------------------------------------------------------------- + + logical (SCRIP_logical), intent(out) :: + & inpoly ! is point in polygon? + + logical (SCRIP_logical), intent(out) :: + & lboundary ! flag points that lie on the boundary + ! of the cell + + integer (SCRIP_i4), intent(out) :: + & edgeid ! if point is on boundary, which local + ! edge is it on? (0 otherwise) +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (SCRIP_i4) :: i, j, k, ic + integer (SCRIP_i4) :: whichpole + + real (SCRIP_r8) :: rns, pi4, ptx, pty, lat, lon, + & cell_center_x, cell_center_y, vec1_lat, vec1_lon + + logical (SCRIP_logical) :: + & latlon + + real (kind=SCRIP_r8), dimension(npseg*ncorners) :: + & cell_corner_x, ! x of each corner of cell + & cell_corner_y ! y of each corner of cell + +!---------------------------------------------------------------------- + + edgeid = 0 + + + !*** IF POINTS ARE ABOVE THE THRESHOLD, CHECK THEM IN A TRANSFORMED + !*** SPACE + !*** HOWEVER, POINTS THAT ARE PRACTICALLY AT THE POLE CANNOT + !*** BE CORRECTLY LOCATED THIS WAY BECAUSE THE POLE IS A SINGULARITY + !*** AND CONTAINMENT IN ANY CELL INCIDENT ON THE POLE WILL GIVE US A + !*** POSITIVE ANSWER. FOR THESE POINTS REVERT TO THE LATLON SPACE + !*** + + if ((ptlat .gt. north_thresh .and. abs(ptlat-pih) .ge. 0.001) .or. + & (ptlat .lt. south_thresh .and. abs(ptlat+pih) .ge. 0.001)) + & then + + if (ptlat > zero) then + pi4 = quart*pi + rns = one + else + pi4 = -quart*pi + rns = -one + endif + + ptx = rns*two*sin(pi4 - half*ptlat)*cos(ptlon) + pty = two*sin(pi4 - half*ptlat)*sin(ptlon) + + latlon = .false. + + ! Since we want greater fidelity for locating the points + ! we send in the mid-points of the polygon edges too + ! BUT THAT MAKES THE POLYGON NON-CONVEX SOMETIMES AND + ! THE CROSS-PRODUCT CHECK FAILS. SO USE CODE TO CHECK GENERAL + ! POLYGONS + + + k = 0 + do i = ncorners, 1, -1 + k = k+1 + lat = cell_corner_lat(i) + lon = cell_corner_lon(i) + cell_corner_x(k) = rns*two*sin(pi4-half*lat)*cos(lon) + cell_corner_y(k) = two*sin(pi4-half*lat)*sin(lon) + + j = i-1 + if (j .eq. 0) j = ncorners ! how do we do (j-1+n)%n in F90? + + vec1_lat = cell_corner_lat(j)-cell_corner_lat(i) + vec1_lon = cell_corner_lon(j)-cell_corner_lon(i) + if (vec1_lon > pi) then + vec1_lon = vec1_lon - pi2 + else if (vec1_lon < -pi) then + vec1_lon = vec1_lon + pi2 + endif + + do j = 1, npseg-1 + k = k+1 + lat = cell_corner_lat(i) + j*vec1_lat/npseg + lon = cell_corner_lon(i) + j*vec1_lon/npseg + cell_corner_x(k) = rns*two*sin(pi4-half*lat)*cos(lon) + cell_corner_y(k) = two*sin(pi4-half*lat)*sin(lon) + enddo + enddo + + !*** cell is so non-convex that no feasible center exists + !*** we have to fall back on a different algorithm + + call ptinpolygen2(ptx, pty, k, cell_corner_x, + & cell_corner_y, latlon, inpoly, lboundary, edgeid) + + if (lboundary) then + edgeid = (edgeid-1)/npseg + 1 ! convert from index in + ! multi-segmented cell to + ! regular cell + endif + else + + latlon = .true. + + whichpole = 0 + if (cell_grid_id .eq. 1 .and. + & cell_add .eq. grid1_spole_cell) then + + whichpole = -1 ! S pole + call ptinpolarpoly(ptlat, ptlon, ncorners, + & cell_corner_lat, cell_corner_lon, + & latlon, whichpole, inpoly, lboundary, edgeid) + + else if (cell_grid_id .eq. 1 .and. + & cell_add .eq. grid1_npole_cell) then + + whichpole = 1 ! N pole + call ptinpolarpoly(ptlat, ptlon, ncorners, + & cell_corner_lat, cell_corner_lon, + & latlon, whichpole, inpoly, lboundary, edgeid) + + else if (cell_grid_id .eq. 2 .and. + & cell_add .eq. grid2_spole_cell) then + + whichpole = -1 ! S pole + call ptinpolarpoly(ptlat, ptlon, ncorners, + & cell_corner_lat, cell_corner_lon, + & latlon, whichpole, inpoly, lboundary, edgeid) + + else if (cell_grid_id .eq. 2 .and. + & cell_add .eq. grid2_npole_cell) then + + whichpole = 1 ! N pole + call ptinpolarpoly(ptlat, ptlon, ncorners, + & cell_corner_lat, cell_corner_lon, + & latlon, whichpole, inpoly, lboundary, edgeid) + + else + + !*** + !*** General cell + !*** + + call ptinpoly(ptlat, ptlon, ncorners, + & cell_corner_lat, cell_corner_lon, + & latlon, inpoly, lboundary, edgeid) + + endif + + endif + + return + +!---------------------------------------------------------------------- + + end subroutine ptincell + +!********************************************************************** + +!********************************************************************** + + subroutine ptinpoly(ptx, pty, ncorners, cell_corner_x, + & cell_corner_y, latlon, inpoly, lboundary, edgeid) + +!---------------------------------------------------------------------- +! +! Check if point is in (convex) polygonal cell +! +!---------------------------------------------------------------------- + + implicit none + +!---------------------------------------------------------------------- +! +! Input arguments +! +!---------------------------------------------------------------------- + + real (SCRIP_r8), intent(in) :: + & ptx, pty ! Point to check + + integer (SCRIP_i4), intent(in) :: + & ncorners ! Number of polygon corners + + real (SCRIP_r8), dimension(ncorners), intent(in) :: + & cell_corner_x, ! Coordinates of cell corners + & cell_corner_y ! Could be x-y or lat-lon or ... + + logical (SCRIP_logical), intent(in) :: + & latlon ! Are coordinates in latlon space? + +!---------------------------------------------------------------------- +! +! Output arguments +! +!---------------------------------------------------------------------- + + logical (SCRIP_logical), intent(out) :: + & inpoly ! Is point in the polygon? + + logical (SCRIP_logical), intent(out) :: + & lboundary ! Is point on the boundary of the polygon? + + integer (SCRIP_i4), intent(out) :: + & edgeid ! if point is on boundary, which local + ! edge is it on? (0 otherwise) + +!---------------------------------------------------------------------- +! +! Local variables +! +!---------------------------------------------------------------------- + + integer (SCRIP_i4) :: n, next_n + + real (SCRIP_r8) :: x1, y1, x2, y2, vec1_x, vec1_y, vec2_x, vec2_y, + & cross_product, minlon, maxlon, ptx_loc, pty_loc + + real (SCRIP_r8), dimension(ncorners) :: + & cell_corner_lat_loc, cell_corner_lon_loc + + + !*********************************************************** + !*** We should just remove the latlon argument since that is + !*** the only coordinate system we are using it for + !*********************************************************** + + + !*** + !*** here we take the cross product of the vector making + !*** up each cell side with the vector formed by the vertex + !*** and search point. if all the cross products are + !*** positive, the point is contained in the cell. + !*** + + inpoly = .false. + lboundary = .false. + edgeid = 0 + + if (.not. latlon) then + + do n = 1, ncorners + next_n = MOD(n,ncorners) + 1 + + x1 = cell_corner_x(n) + y1 = cell_corner_y(n) + x2 = cell_corner_x(next_n) + y2 = cell_corner_y(next_n) + + vec1_x = x2 - x1 + vec1_y = y2 - y1 + vec2_x = ptx - x1 + vec2_y = pty - y1 + + cross_product = vec1_y*vec2_x - vec2_y*vec1_x + + !*** + !*** if the cross product for a side is zero, the point + !*** lies exactly on the side or the side is degenerate + !*** (zero length). if degenerate, set the cross + !*** product to a positive number. + !*** + + if (abs(cross_product) < tiny) then + if (vec1_x*vec1_x + vec1_y*vec1_y .le. tiny*tiny) then + cross_product = one + else + lboundary = .true. + edgeid = n + endif + else + + !*** + !*** if cross product is less than zero, this cell + !*** doesn't work + !*** + !*** Should we say "if (cp < zero .and. abs(cp) > tiny)" ? + + if (cross_product < zero) then + inpoly = .false. + lboundary = .false. + return + endif + endif + + end do + + else + + !*** Checking in latlon space + !*** If the grid cell coordinates spans more than pi radians + !*** transform the coordinates so that they don't + + cell_corner_lat_loc = cell_corner_x + cell_corner_lon_loc = cell_corner_y + + minlon = 9999.0 + maxlon = -9999.0 + do n = 1, ncorners + if (cell_corner_lon_loc(n) < minlon) then + minlon = cell_corner_lon_loc(n) + endif + if (cell_corner_lon_loc(n) > maxlon) then + maxlon = cell_corner_lon_loc(n) + endif + enddo + + if (maxlon-minlon > pi) then + + do n = 1, ncorners + if (cell_corner_lon_loc(n)-minlon > pi) then + cell_corner_lon_loc(n) = cell_corner_lon_loc(n)-pi2 + endif + enddo + + endif + + ptx_loc = ptx + pty_loc = pty + if (pty_loc - minlon > pi) then + pty_loc = pty_loc - pi2 + else if (pty_loc - minlon < -pi) then + pty_loc = pty_loc + pi2 + endif + + + do n = 1, ncorners + next_n = MOD(n,ncorners) + 1 + + x1 = cell_corner_lat_loc(n) + y1 = cell_corner_lon_loc(n) + x2 = cell_corner_lat_loc(next_n) + y2 = cell_corner_lon_loc(next_n) + + vec1_x = x2 - x1 + vec1_y = y2 - y1 + vec2_x = ptx_loc - x1 + vec2_y = pty_loc - y1 + + cross_product = vec1_y*vec2_x - vec2_y*vec1_x + + !*** + !*** if the cross product for a side is zero, the point + !*** lies exactly on the side or the side is degenerate + !*** (zero length). if degenerate, set the cross + !*** product to a positive number. + !*** + + if (abs(cross_product) < tiny) then + if (vec1_x*vec1_x + vec1_y*vec1_y .le. tiny*tiny) then + cross_product = one + else + lboundary = .true. + edgeid = n + endif + else + + !*** + !*** if cross product is less than zero, this cell + !*** doesn't work + !*** + !*** Should we say "if (cp < zero .and. abs(cp) > tiny)" ? + + if (cross_product < zero) then + inpoly = .false. + lboundary = .false. + return + endif + endif + + end do + + endif + !*** + !*** if cross products all positive, we found the location + !*** + + inpoly = .true. + return + +!---------------------------------------------------------------------- + + end subroutine ptinpoly + +!********************************************************************** + + + + subroutine ptinpolarpoly(ptx, pty, ncorners, cell_corner_x, + & cell_corner_y, latlon, whichpole, inpoly, lboundary, edgeid) + +!---------------------------------------------------------------------- +! +! Check if point is in polygonal cell overlapping the pole +! Cannot check the containment as is in latlon space - We have +! to check by connecting each edge of the polygon to the pole +! and check containment in the resulting quadrilateral in latlon +! space +! The cell can be non-convex as long as the pole is 'visible' to +! all the edges of the polygon, i.e., we can connect the pole to +! each edge of the polygon and form a triangle with positive area +! +!---------------------------------------------------------------------- + + implicit none + +!---------------------------------------------------------------------- +! +! Input arguments +! +!---------------------------------------------------------------------- + + real (SCRIP_r8), intent(in) :: + & ptx, pty ! Point to check + + integer (SCRIP_i4), intent(in) :: + & ncorners ! Number of polygon corners + + real (SCRIP_r8), dimension(ncorners), intent(in) :: + & cell_corner_x, ! Coordinates of cell corners + & cell_corner_y ! Could be x-y or lat-lon or ... + + logical (SCRIP_logical), intent(in) :: + & latlon ! Are coordinates in latlon space? + + integer (SCRIP_i4), intent(in) :: + & whichpole ! South or North pole + +!---------------------------------------------------------------------- +! +! Output arguments +! +!---------------------------------------------------------------------- + + logical (SCRIP_logical), intent(out) :: + & inpoly ! Is point in the polygon? + + logical (SCRIP_logical), intent(out) :: + & lboundary ! Is point on the boundary of the polygon? + + integer (SCRIP_i4), intent(out) :: + & edgeid ! if point is on boundary, which local + ! edge is it on? (0 otherwise) + +!---------------------------------------------------------------------- +! +! Local variables +! +!---------------------------------------------------------------------- + + integer (SCRIP_i4) :: n, next_n, ledgeid + + real (SCRIP_r8), dimension(4) :: + & pquad_corner_x, ! Coordinates of polar quad + & pquad_corner_y + + real (SCRIP_r8) :: x1, y1, x2, y2, vec1_x, vec1_y, vec2_x, vec2_y, + & cross_product, pole_lat + + pole_lat = whichpole*pih + + !*** + !*** This is a polygon that overlaps the pole + !*** A normal point in polygon check could fail + !*** So, with each edge of the polygon form a quadrilateral + !*** in latlon space using the polar latitude and the longitude + !*** values of the endpoints of the edge. Then check containment + !*** of the point in this quadrilateral + !*** + + inpoly = .false. + lboundary = .false. + + do n = 1, ncorners + next_n = MOD(n,ncorners) + 1 + + pquad_corner_x(1) = cell_corner_x(n) + pquad_corner_y(1) = cell_corner_y(n) + pquad_corner_x(2) = cell_corner_x(next_n) + pquad_corner_y(2) = cell_corner_y(next_n) + pquad_corner_x(3) = pole_lat + pquad_corner_y(3) = cell_corner_y(next_n) + pquad_corner_x(4) = pole_lat + pquad_corner_y(4) = cell_corner_y(n) + + + call ptinpoly(ptx,pty,4,pquad_corner_x,pquad_corner_y, + & latlon,inpoly,lboundary, ledgeid) + + if (inpoly) then + + if (lboundary) then + + !*** + !*** Check to see if the lboundary flag is being + !*** triggered by the outer edge of the polygon or + !*** by one of the artificial internal edges + !*** + + vec1_x = pquad_corner_x(2) - pquad_corner_x(1) + vec1_y = pquad_corner_y(2) - pquad_corner_y(1) + vec2_x = ptx - pquad_corner_x(1) + vec2_y = pty - pquad_corner_y(1) + + + if (latlon) then + + !*** + !*** check for 0,2pi crossings + !*** + + if (vec1_y > pi) vec1_y = vec1_y - pi2 + if (vec1_y < -pi) vec1_y = vec1_y + pi2 + if (vec2_y > pi) vec2_y = vec2_y - pi2 + if (vec2_y < -pi) vec2_y = vec2_y + pi2 + + endif + + cross_product = vec1_y*vec2_x - vec2_y*vec1_x + + !*** + !*** if the cross product for a side is zero, the point + !*** lies exactly on the side or the side is degenerate + !*** (zero length). if degenerate, set the cross + !*** product to a positive number. + !*** + + if (abs(cross_product) < tiny) then + if (vec1_x .eq. zero .and. vec1_y .eq. zero) then + cross_product = one + lboundary = .false. + else + edgeid = n + lboundary = .true. + endif + else + lboundary = .false. + endif + endif ! if (lboundary) + + return ! pt in polygon + + endif ! if (inpoly) + + end do + + return ! pt outside polygon + +!---------------------------------------------------------------------- + + end subroutine ptinpolarpoly + +!********************************************************************** + + + + subroutine ptinpolygen(ptx, pty, ncorners, cell_corner_x, + & cell_corner_y, cell_center_x, cell_center_y, + & latlon, inpoly, lboundary, edgeid) + +!---------------------------------------------------------------------- +! +! Check if point is in general (convex or mildly non-convex) +! polygonal cell by connecting each edge of the polygon to a +! a central point (average of vertices) and check containment in +! the resulting triangle +! +! The cell can be non-convex as long as the 'center' is 'visible' to +! all the edges of the polygon, i.e., we can connect the 'center' to +! each edge of the polygon and form a triangle with positive area +! +!---------------------------------------------------------------------- + + implicit none + +!---------------------------------------------------------------------- +! +! Input arguments +! +!---------------------------------------------------------------------- + + real (SCRIP_r8), intent(in) :: + & ptx, pty ! Point to check + + integer (SCRIP_i4), intent(in) :: + & ncorners ! Number of polygon corners + + real (SCRIP_r8), dimension(ncorners), intent(in) :: + & cell_corner_x, ! Coordinates of cell corners + & cell_corner_y ! Could be x-y or lat-lon or ... + + real (SCRIP_r8), intent(in) :: + & cell_center_x, + & cell_center_y + + logical (SCRIP_logical), intent(in) :: + & latlon ! Are coordinates in latlon space? + +!---------------------------------------------------------------------- +! +! Output arguments +! +!---------------------------------------------------------------------- + + logical (SCRIP_logical), intent(out) :: + & inpoly ! Is point in the polygon? + + logical (SCRIP_logical), intent(out) :: + & lboundary ! Is point on the boundary of the polygon? + + integer (SCRIP_i4), intent(out) :: + & edgeid ! if point is on boundary, which local + ! edge is it on? (0 otherwise) + +!---------------------------------------------------------------------- +! +! Local variables +! +!---------------------------------------------------------------------- + + integer (SCRIP_i4) :: n, next_n, ledgeid + + real (SCRIP_r8), dimension(3) :: + & tri_corner_x, ! Coordinates of triangle + & tri_corner_y + + real (SCRIP_r8) :: x1, y1, x2, y2, vec1_x, vec1_y, vec2_x, vec2_y, + & cross_product + + + !*** + !*** So, with each edge of the polygon form a triangle + !*** by connecting a 'central' point to the endpoints of + !*** the edge. Then check containment of the point in this tri + !*** + + inpoly = .false. + lboundary = .false. + + do n = 1, ncorners + next_n = MOD(n,ncorners) + 1 + + tri_corner_x(1) = cell_corner_x(n) + tri_corner_y(1) = cell_corner_y(n) + tri_corner_x(2) = cell_corner_x(next_n) + tri_corner_y(2) = cell_corner_y(next_n) + tri_corner_x(3) = cell_center_x + tri_corner_y(3) = cell_center_y + + vec1_x = tri_corner_x(2) - tri_corner_x(1) + vec1_y = tri_corner_y(2) - tri_corner_y(1) + + !*** Skip triangles arising from degenerate edges + + if (vec1_x*vec1_x+vec1_y*vec1_y .le. tiny*tiny) cycle + + call ptinpoly(ptx,pty,3,tri_corner_x,tri_corner_y, + & latlon,inpoly,lboundary, ledgeid) + + if (inpoly) then + + if (lboundary) then + + !*** + !*** Check to see if the lboundary flag is being + !*** triggered by the outer edge of the polygon or + !*** by one of the artificial internal edges + !*** + + vec2_x = ptx - tri_corner_x(1) + vec2_y = pty - tri_corner_y(1) + + + if (latlon) then + + !*** + !*** check for 0,2pi crossings + !*** + + if (vec1_y > pi) vec1_y = vec1_y - pi2 + if (vec1_y < -pi) vec1_y = vec1_y + pi2 + if (vec2_y > pi) vec2_y = vec2_y - pi2 + if (vec2_y < -pi) vec2_y = vec2_y + pi2 + + endif + + cross_product = vec1_y*vec2_x - vec2_y*vec1_x + + !*** + !*** if the cross product for a side is zero, the point + !*** lies exactly on the side or the side is degenerate + !*** (zero length). if degenerate, set the cross + !*** product to a positive number. + !*** + + if (abs(cross_product) < tiny) then + if (vec1_x*vec1_x+vec1_y*vec1_y .le. tiny*tiny) then + cross_product = one + lboundary = .false. + else + edgeid = n + lboundary = .true. + endif + else + lboundary = .false. + endif + endif ! if (lboundary) + + return ! pt in polygon + + endif ! if (inpoly) + + end do + + return ! pt outside polygon + +!---------------------------------------------------------------------- + + end subroutine ptinpolygen + +!********************************************************************** + + + + subroutine ptinpolygen2(ptx, pty, ncorners, cell_corner_x, + & cell_corner_y, latlon, inpoly, lboundary, edgeid) + +!---------------------------------------------------------------------- +! +! Check if point is in general (convex or mildly non-convex) +! polygonal cell by connecting each edge of the polygon to a +! a central point (average of vertices) and check containment in +! the resulting triangle +! +! The cell can be non-convex as long as the 'center' is 'visible' to +! all the edges of the polygon, i.e., we can connect the 'center' to +! each edge of the polygon and form a triangle with positive area +! +!---------------------------------------------------------------------- + + implicit none + +!---------------------------------------------------------------------- +! +! Input arguments +! +!---------------------------------------------------------------------- + + real (SCRIP_r8), intent(in) :: + & ptx, pty ! Point to check + + integer (SCRIP_i4), intent(in) :: + & ncorners ! Number of polygon corners + + real (SCRIP_r8), dimension(ncorners), intent(in) :: + & cell_corner_x, ! Coordinates of cell corners + & cell_corner_y ! Could be x-y or lat-lon or ... + + logical (SCRIP_logical), intent(in) :: + & latlon ! Are coordinates in latlon space? + +!---------------------------------------------------------------------- +! +! Output arguments +! +!---------------------------------------------------------------------- + + logical (SCRIP_logical), intent(out) :: + & inpoly ! Is point in the polygon? + + logical (SCRIP_logical), intent(out) :: + & lboundary ! Is point on the boundary of the polygon? + + integer (SCRIP_i4), intent(out) :: + & edgeid ! if point is on boundary, which local + ! edge is it on? (0 otherwise) + +!---------------------------------------------------------------------- +! +! Local variables +! +!---------------------------------------------------------------------- + + integer (SCRIP_i4) :: c, n, next_n + + real (SCRIP_r8) :: x1, y1, x2, y2, vec1_x, vec1_y, vec2_x, vec2_y, + & vec3_x, vec3_y, vec1_len, vec2_len, vec3_len, + & cross_product, dot_product + + + !*** + !*** So, with each edge of the polygon form a triangle + !*** by connecting a 'central' point to the endpoints of + !*** the edge. Then check containment of the point in this tri + !*** + + inpoly = .false. + lboundary = .false. + + c = 0 + do n = 1, ncorners + next_n = MOD(n,ncorners) + 1 + + x1 = cell_corner_x(n) + y1 = cell_corner_y(n) + x2 = cell_corner_x(next_n) + y2 = cell_corner_y(next_n) + + if (((y1 > pty .and. y2 <= pty) .or. + & (y2 > pty .and. y1 <= pty)) .and. + & (ptx <= (x1 + (pty-y1)*(x2-x1)/(y2-y1)))) then + + c = 1 - c + + endif + enddo + + if (c .eq. 1) inpoly = .true. + + + !*** Check if the point is on the boundary of the polygon + + do n = 1, ncorners + + next_n = MOD(n,ncorners) + 1 + + x1 = cell_corner_x(n) + y1 = cell_corner_y(n) + x2 = cell_corner_x(next_n) + y2 = cell_corner_y(next_n) + + vec1_x = x2 - x1 + vec1_y = y2 - y1 + vec1_len = sqrt(vec1_x*vec1_x + vec1_y*vec1_y) + vec1_x = vec1_x/vec1_len + vec1_y = vec1_y/vec1_len + + vec2_x = ptx - x1 + vec2_y = pty - y1 + vec2_len = sqrt(vec2_x*vec2_x + vec2_y*vec2_y) + + cross_product = vec1_x*vec2_y - vec2_x*vec1_y + if (abs(cross_product) > tiny .and. vec2_len > tiny) then + cross_product = cross_product/vec2_len + endif + + if (abs(cross_product) < 1e5*tiny .and. + & abs(cross_product) > 10*tiny) then + + !*** Sometimes when the point is too close to a vertex + !*** then the cross product computation has errors due + !*** to subtraction of two small numbers - So check w.r.t. + !*** other vertex of the segment as well + + vec3_x = ptx - x2 + vec3_y = pty - y2 + vec3_len = sqrt(vec3_x*vec3_x + vec3_y*vec3_y) + + cross_product = -vec1_x*vec3_y + vec1_y*vec3_x + if (abs(cross_product) > tiny .and. vec3_len > tiny) then + !*** + !*** Normalize only if we won't be dividing two small + !*** numbers + cross_product = cross_product/vec3_len + endif + endif + + if (abs(cross_product) < 10*tiny) then + + if (vec1_x*vec1_x+vec1_y*vec1_y .le. tiny*tiny) then + cross_product = one + else + dot_product = vec1_x*vec2_x + vec1_y*vec2_y + + if (dot_product >= 0 .and. dot_product <= vec1_len) then + inpoly = .true. + lboundary = .true. + edgeid = n + exit + endif + endif + endif + + enddo + + return + +!---------------------------------------------------------------------- + + end subroutine ptinpolygen2 + +!********************************************************************** + + + + + +!---------------------------------------------------------------------- +! +!---------------------------------------------------------------------- + + subroutine get_srch_cells(cell_add, cell_grid_num, srch_grid_num, + & num_srch_cells, srch_add, srch_corners, + & srch_corner_lat, srch_corner_lon, + & srch_center_lat, srch_center_lon) + +!---------------------------------------------------------------------- +! +! Input arguments +! +!---------------------------------------------------------------------- + + integer (SCRIP_i4), intent(in) :: + & cell_add, ! cell in whose nbrhood we must find other + & cell_grid_num, ! cells grid number from which 'cell_add' + & srch_grid_num ! is grid number in which we must find + ! search cells + +!---------------------------------------------------------------------- +! +! Output arguments +! +!---------------------------------------------------------------------- + + integer (SCRIP_i4), intent(out) :: + & num_srch_cells, + & srch_corners ! Number of corners for search cells + + integer (SCRIP_i4), dimension(:), allocatable, intent(out) :: + & srch_add ! Global addresses of search cells + + real (SCRIP_r8), dimension(:,:), allocatable, intent(out) :: + & srch_corner_lat, srch_corner_lon + + real (SCRIP_r8), dimension(:), allocatable, intent(out) :: + & srch_center_lat, srch_center_lon + + +!----------------------------------------------------------------------- +! +! Local arguments +! +!----------------------------------------------------------------------- + + logical (SCRIP_logical), dimension(:), allocatable :: + & srch_mask + + integer (SCRIP_i4) :: grid1_add, grid2_add, max_add, min_add, + & n + +!----------------------------------------------------------------------- + + num_srch_cells = 0 + + !*** + !*** restrict searches first using search bins + !*** + + if (last_cell_add_get_srch_cells /= cell_add .or. + & last_cell_grid_num_get_srch_cells /= cell_grid_num .or. + & last_srch_grid_num_get_srch_cells /= srch_grid_num) then + + if (first_call_get_srch_cells) then + first_call_get_srch_cells = .false. + num_srch_cells_loc_get_srch_cells = 0 + srch_corners_loc_get_srch_cells = 0 + last_cell_add_get_srch_cells = 0 + last_cell_grid_num_get_srch_cells = 0 + last_srch_grid_num_get_srch_cells = 0 + else + if (num_srch_cells_loc_get_srch_cells .gt. 0) then + deallocate(srch_add_loc_get_srch_cells, + & srch_corner_lat_loc_get_srch_cells, + & srch_corner_lon_loc_get_srch_cells, + & srch_center_lat_loc_get_srch_cells, + & srch_center_lon_loc_get_srch_cells) + endif + + endif + + + last_cell_add_get_srch_cells = cell_add + last_cell_grid_num_get_srch_cells = cell_grid_num + last_srch_grid_num_get_srch_cells = srch_grid_num + + + if (cell_grid_num == 1) then + + if (srch_grid_num == 1) then + + !*** Grid 1 neighbors of grid 1 cell + + allocate(srch_mask(grid1_size)) + + min_add = grid1_size + max_add = 1 + do n=1,num_srch_bins + if (cell_add >= bin_addr1(1,n) .and. + & cell_add <= bin_addr1(2,n)) then + min_add = min(min_add, bin_addr1(1,n)) + max_add = max(max_add, bin_addr1(2,n)) + endif + end do + + !*** + !*** further restrict searches using bounding boxes + !*** + + num_srch_cells_loc_get_srch_cells = 0 + do grid1_add = min_add,max_add + srch_mask(grid1_add) = + & (grid1_bound_box(1,grid1_add) <= + & grid1_bound_box(2,cell_add)) .and. + & (grid1_bound_box(2,grid1_add) >= + & grid1_bound_box(1,cell_add)) .and. + & (grid1_bound_box(3,grid1_add) <= + & grid1_bound_box(4,cell_add)) .and. + & (grid1_bound_box(4,grid1_add) >= + & grid1_bound_box(3,cell_add)) + + if (srch_mask(grid1_add)) + & num_srch_cells_loc_get_srch_cells = + & num_srch_cells_loc_get_srch_cells+1 + end do + + if (num_srch_cells_loc_get_srch_cells /= 0) then + + !*** + !*** create search arrays + !*** + + allocate(srch_add_loc_get_srch_cells + & (num_srch_cells_loc_get_srch_cells), + & srch_corner_lat_loc_get_srch_cells + & (grid1_corners,num_srch_cells_loc_get_srch_cells), + & srch_corner_lon_loc_get_srch_cells + & (grid1_corners,num_srch_cells_loc_get_srch_cells), + & srch_center_lat_loc_get_srch_cells + & (num_srch_cells_loc_get_srch_cells), + & srch_center_lon_loc_get_srch_cells + & (num_srch_cells_loc_get_srch_cells)) + + n = 0 + do grid1_add = min_add,max_add + if (srch_mask(grid1_add)) then + n = n+1 + srch_add_loc_get_srch_cells(n) = grid1_add + srch_corner_lat_loc_get_srch_cells(:,n) = + & grid1_corner_lat(:,grid1_add) + srch_corner_lon_loc_get_srch_cells(:,n) = + & grid1_corner_lon(:,grid1_add) + srch_center_lat_loc_get_srch_cells(n) = + & grid1_center_lat(grid1_add) + srch_center_lon_loc_get_srch_cells(n) = + & grid1_center_lon(grid1_add) + endif + end do + + srch_corners_loc_get_srch_cells = grid1_corners + endif + + deallocate(srch_mask) + + else + + !*** Grid 2 neighbors of grid 1 cell + + allocate(srch_mask(grid2_size)) + + min_add = grid2_size + max_add = 1 + do n=1,num_srch_bins + if (cell_add >= bin_addr1(1,n) .and. + & cell_add <= bin_addr1(2,n)) then + min_add = min(min_add, bin_addr2(1,n)) + max_add = max(max_add, bin_addr2(2,n)) + endif + end do + + !*** + !*** further restrict searches using bounding boxes + !*** + + num_srch_cells_loc_get_srch_cells = 0 + do grid2_add = min_add,max_add + srch_mask(grid2_add) = + & (grid2_bound_box(1,grid2_add) <= + & grid1_bound_box(2,cell_add)) .and. + & (grid2_bound_box(2,grid2_add) >= + & grid1_bound_box(1,cell_add)) .and. + & (grid2_bound_box(3,grid2_add) <= + & grid1_bound_box(4,cell_add)) .and. + & (grid2_bound_box(4,grid2_add) >= + & grid1_bound_box(3,cell_add)) + + + + if (srch_mask(grid2_add)) + & num_srch_cells_loc_get_srch_cells = + & num_srch_cells_loc_get_srch_cells+1 + end do + + + if (num_srch_cells_loc_get_srch_cells /= 0) then + + !*** + !*** create search arrays + !*** + + allocate(srch_add_loc_get_srch_cells( + & num_srch_cells_loc_get_srch_cells), + & srch_corner_lat_loc_get_srch_cells( + & grid2_corners,num_srch_cells_loc_get_srch_cells), + & srch_corner_lon_loc_get_srch_cells( + & grid2_corners,num_srch_cells_loc_get_srch_cells), + & srch_center_lat_loc_get_srch_cells( + & num_srch_cells_loc_get_srch_cells), + & srch_center_lon_loc_get_srch_cells( + & num_srch_cells_loc_get_srch_cells)) + + n = 0 + do grid2_add = min_add,max_add + if (srch_mask(grid2_add)) then + n = n+1 + srch_add_loc_get_srch_cells(n) = grid2_add + srch_corner_lat_loc_get_srch_cells(:,n) = + & grid2_corner_lat(:,grid2_add) + srch_corner_lon_loc_get_srch_cells(:,n) = + & grid2_corner_lon(:,grid2_add) + srch_center_lat_loc_get_srch_cells(n) = + & grid2_center_lat(grid2_add) + srch_center_lon_loc_get_srch_cells(n) = + & grid2_center_lon(grid2_add) + endif + end do + + srch_corners_loc_get_srch_cells = grid2_corners + endif + + deallocate(srch_mask) + endif + + else + + if (srch_grid_num == 1) then + + !*** Grid 1 neighbors of grid 2 cell + + allocate(srch_mask(grid1_size)) + + min_add = grid1_size + max_add = 1 + do n=1,num_srch_bins + if (cell_add >= bin_addr2(1,n) .and. + & cell_add <= bin_addr2(2,n)) then + min_add = min(min_add, bin_addr1(1,n)) + max_add = max(max_add, bin_addr1(2,n)) + endif + end do + + !*** + !*** further restrict searches using bounding boxes + !*** + + num_srch_cells_loc_get_srch_cells = 0 + do grid1_add = min_add,max_add + srch_mask(grid1_add) = + & (grid1_bound_box(1,grid1_add) <= + & grid2_bound_box(2,cell_add)) .and. + & (grid1_bound_box(2,grid1_add) >= + & grid2_bound_box(1,cell_add)) .and. + & (grid1_bound_box(3,grid1_add) <= + & grid2_bound_box(4,cell_add)) .and. + & (grid1_bound_box(4,grid1_add) >= + & grid2_bound_box(3,cell_add)) + + if (srch_mask(grid1_add)) + & num_srch_cells_loc_get_srch_cells = + & num_srch_cells_loc_get_srch_cells+1 + end do + + + if (num_srch_cells_loc_get_srch_cells /= 0) then + + !*** + !*** create search arrays + !*** + + allocate(srch_add_loc_get_srch_cells( + & num_srch_cells_loc_get_srch_cells), + & srch_corner_lat_loc_get_srch_cells( + & grid1_corners,num_srch_cells_loc_get_srch_cells), + & srch_corner_lon_loc_get_srch_cells( + & grid1_corners,num_srch_cells_loc_get_srch_cells), + & srch_center_lat_loc_get_srch_cells( + & num_srch_cells_loc_get_srch_cells), + & srch_center_lon_loc_get_srch_cells( + & num_srch_cells_loc_get_srch_cells)) + + n = 0 + do grid1_add = min_add,max_add + if (srch_mask(grid1_add)) then + n = n+1 + srch_add_loc_get_srch_cells(n) = grid1_add + srch_corner_lat_loc_get_srch_cells(:,n) = + & grid1_corner_lat(:,grid1_add) + srch_corner_lon_loc_get_srch_cells(:,n) = + & grid1_corner_lon(:,grid1_add) + srch_center_lat_loc_get_srch_cells(n) = + & grid1_center_lat(grid1_add) + srch_center_lon_loc_get_srch_cells(n) = + & grid1_center_lon(grid1_add) + endif + end do + + srch_corners_loc_get_srch_cells = grid1_corners + endif + + deallocate(srch_mask) + + else + + !*** Grid 2 neighbors of grid 2 cell + + allocate(srch_mask(grid2_size)) + + min_add = grid2_size + max_add = 1 + do n=1,num_srch_bins + if (cell_add >= bin_addr2(1,n) .and. + & cell_add <= bin_addr2(2,n)) then + min_add = min(min_add, bin_addr2(1,n)) + max_add = max(max_add, bin_addr2(2,n)) + endif + end do + + !*** + !*** further restrict searches using bounding boxes + !*** + + num_srch_cells_loc_get_srch_cells = 0 + do grid2_add = min_add,max_add + srch_mask(grid2_add) = + & (grid2_bound_box(1,grid2_add) <= + & grid2_bound_box(2,cell_add)) .and. + & (grid2_bound_box(2,grid2_add) >= + & grid2_bound_box(1,cell_add)) .and. + & (grid2_bound_box(3,grid2_add) <= + & grid2_bound_box(4,cell_add)) .and. + & (grid2_bound_box(4,grid2_add) >= + & grid2_bound_box(3,cell_add)) + + if (srch_mask(grid2_add)) + & num_srch_cells_loc_get_srch_cells = + & num_srch_cells_loc_get_srch_cells+1 + end do + + + if (num_srch_cells_loc_get_srch_cells /= 0) then + + !*** + !*** create search arrays + !*** + + allocate(srch_add_loc_get_srch_cells( + & num_srch_cells_loc_get_srch_cells), + & srch_corner_lat_loc_get_srch_cells( + & grid2_corners,num_srch_cells_loc_get_srch_cells), + & srch_corner_lon_loc_get_srch_cells( + & grid2_corners,num_srch_cells_loc_get_srch_cells), + & srch_center_lat_loc_get_srch_cells( + & num_srch_cells_loc_get_srch_cells), + & srch_center_lon_loc_get_srch_cells( + & num_srch_cells_loc_get_srch_cells)) + + n = 0 + do grid2_add = min_add,max_add + if (srch_mask(grid2_add)) then + n = n+1 + srch_add_loc_get_srch_cells(n) = grid2_add + srch_corner_lat_loc_get_srch_cells(:,n) = + & grid2_corner_lat(:,grid2_add) + srch_corner_lon_loc_get_srch_cells(:,n) = + & grid2_corner_lon(:,grid2_add) + srch_center_lat_loc_get_srch_cells(n) = + & grid2_center_lat(grid2_add) + srch_center_lon_loc_get_srch_cells(n) = + & grid2_center_lon(grid2_add) + endif + end do + + srch_corners_loc_get_srch_cells = grid2_corners + endif + + deallocate(srch_mask) + + endif + + endif + + endif + + + num_srch_cells = num_srch_cells_loc_get_srch_cells + + if (num_srch_cells .eq. 0) then + return + endif + + srch_corners = srch_corners_loc_get_srch_cells + allocate(srch_add(num_srch_cells), + & srch_corner_lat(srch_corners,num_srch_cells), + & srch_corner_lon(srch_corners,num_srch_cells), + & srch_center_lat(num_srch_cells), + & srch_center_lon(num_srch_cells)) + srch_add = srch_add_loc_get_srch_cells + srch_corner_lat = srch_corner_lat_loc_get_srch_cells + srch_corner_lon = srch_corner_lon_loc_get_srch_cells + srch_center_lat = srch_center_lat_loc_get_srch_cells + srch_center_lon = srch_center_lon_loc_get_srch_cells + + end subroutine get_srch_cells + + +!********************************************************************** + + +!---------------------------------------------------------------------- +! +! Find cell adjacent to edge (edge_id) of given cell (cell_add) +! +!---------------------------------------------------------------------- + + subroutine find_adj_cell(cell_add, edge_id, cell_grid_num, + & adj_add) + +!---------------------------------------------------------------------- +! +! Input variables +! +!---------------------------------------------------------------------- + + integer (SCRIP_i4), intent(in) :: + & cell_add, ! cell whose edge we are checking + & edge_id, ! index of edge that we are check + & cell_grid_num ! grid to which cell belongs + +!---------------------------------------------------------------------- +! +! Output variables +! +!---------------------------------------------------------------------- + + integer (SCRIP_i4), intent(out) :: adj_add + +!---------------------------------------------------------------------- +! +! Local variables +! +!---------------------------------------------------------------------- + + integer (SCRIP_i4) :: i, inx, n, global_add + logical (SCRIP_logical) :: found + real (SCRIP_r8) :: lat1, lon1, lat2, lon2 + + adj_add = 0 + + if (cell_grid_num .eq. 1) then + + i = edge_id + inx = 1 + mod(edge_id,grid1_corners) + + lat1 = grid1_corner_lat(i,cell_add) + lon1 = grid1_corner_lon(i,cell_add) + lat2 = grid1_corner_lat(inx,cell_add) + lon2 = grid1_corner_lon(inx,cell_add) + + !*** + !*** Often the cell with the next or previous index is + !*** the adjacent cell. Check that first + !*** + + if (cell_add .lt. grid1_size) then + + global_add = cell_add + 1 + + do i = 1, grid1_corners + inx = mod(i,grid1_corners)+1 + if (abs(grid1_corner_lat(inx,global_add)-lat1) .le. tiny + & .and. + & abs(grid1_corner_lat(i,global_add)-lat2) .le. tiny + & .and. + & abs(grid1_corner_lon(inx,global_add)-lon1) .le. tiny + & .and. + & abs(grid1_corner_lon(i,global_add)-lon2) .le. tiny) + & then + + adj_add = global_add + return + endif + enddo + + endif + + if (cell_add .gt. 1) then + + global_add = cell_add - 1 + + do i = 1, grid1_corners + inx = mod(i,grid1_corners)+1 + if (abs(grid1_corner_lat(inx,global_add)-lat1) .le. tiny + & .and. + & abs(grid1_corner_lat(i,global_add)-lat2) .le. tiny + & .and. + & abs(grid1_corner_lon(inx,global_add)-lon1) .le. tiny + & .and. + & abs(grid1_corner_lon(i,global_add)-lon2) .le. tiny) + & then + + adj_add = global_add + return + endif + enddo + + endif + + + + else + + i = edge_id + inx = 1 + mod(edge_id,grid2_corners) + + lat1 = grid2_corner_lat(i,cell_add) + lon1 = grid2_corner_lon(i,cell_add) + lat2 = grid2_corner_lat(inx,cell_add) + lon2 = grid2_corner_lon(inx,cell_add) + + + !*** + !*** Often the cell with the next or previous index is + !*** the adjacent cell. Check that first + !*** + + if (cell_add .lt. grid2_size) then + + global_add = cell_add + 1 + + do i = 1, grid2_corners + inx = mod(i,grid2_corners)+1 + if (abs(grid2_corner_lat(inx,global_add)-lat1) .le. tiny + & .and. + & abs(grid2_corner_lat(i,global_add)-lat2) .le. tiny + & .and. + & abs(grid2_corner_lon(inx,global_add)-lon1) .le. tiny + & .and. + & abs(grid2_corner_lon(i,global_add)-lon2) .le. tiny) + & then + + adj_add = global_add + return + endif + enddo + + endif + + if (cell_add .gt. 1) then + + global_add = cell_add - 1 + + do i = 1, grid2_corners + inx = mod(i,grid2_corners)+1 + if (abs(grid2_corner_lat(inx,global_add)-lat1) .le. tiny + & .and. + & abs(grid2_corner_lat(i,global_add)-lat2) .le. tiny + & .and. + & abs(grid2_corner_lon(inx,global_add)-lon1) .le. tiny + & .and. + & abs(grid2_corner_lon(i,global_add)-lon2) .le. tiny) + & then + + adj_add = global_add + return + endif + enddo + + endif + + + endif + + + if (cell_add /= last_cell_find_adj_cell .or. + & cell_grid_num /= last_cell_grid_num_find_adj_cell) then + + last_cell_find_adj_cell = cell_add + last_cell_grid_num_find_adj_cell = cell_grid_num + + if (first_call_find_adj_cell) then + first_call_find_adj_cell = .false. + last_cell_find_adj_cell = 0 + last_cell_grid_num_find_adj_cell = 0 + else + if (num_srch_cells_find_adj_cell .gt. 0) then + deallocate(srch_add_find_adj_cell, + & srch_corner_lat_find_adj_cell, + & srch_corner_lon_find_adj_cell, + & srch_center_lat_find_adj_cell, + & srch_center_lon_find_adj_cell) + endif + endif + + call get_srch_cells(cell_add, cell_grid_num, cell_grid_num, + & num_srch_cells_find_adj_cell, srch_add_find_adj_cell, + & srch_corners_find_adj_cell, srch_corner_lat_find_adj_cell, + & srch_corner_lon_find_adj_cell, + & srch_center_lat_find_adj_cell, + & srch_center_lon_find_adj_cell) + + endif + + + found = .false. + do n = 1, num_srch_cells_find_adj_cell + + global_add = srch_add_find_adj_cell(n) + + do i = 1, srch_corners_find_adj_cell + inx = mod(i,srch_corners_find_adj_cell)+1 + if (abs(srch_corner_lat_find_adj_cell(inx,n)-lat1) .le. tiny + & .and. + & abs(srch_corner_lat_find_adj_cell(i,n)-lat2) .le. tiny + & .and. + & abs(srch_corner_lon_find_adj_cell(inx,n)-lon1) .le.tiny + & .and. + & abs(srch_corner_lon_find_adj_cell(i,n)-lon2) .le. tiny) + & then + + adj_add = global_add + found = .true. + + exit + endif + enddo + + if (found) exit + + enddo + + return + end subroutine find_adj_cell + + +!---------------------------------------------------------------------- +! +! Given points inside and outside a cell, converge to the boundary +! +!---------------------------------------------------------------------- + + + subroutine converge_to_bdry(cell_add, cell_grid_num, + & ncorners, cell_corner_lat, + & cell_corner_lon, cell_center_lat, cell_center_lon, + & inpt_lat, inpt_lon, outpt_lat, outpt_lon, + & bpt_lat, bpt_lon, bedgeid) + +!---------------------------------------------------------------------- +! +! Input variables +! +!---------------------------------------------------------------------- + + integer (SCRIP_i4), intent(in) :: + & cell_add, ! Cell in which we are operating + & cell_grid_num, ! Grid to which cell belongs + & ncorners ! Number of corners in cell + + real (SCRIP_r8), dimension(ncorners), intent(in) :: + & cell_corner_lat, ! Latitude values of cell corners + & cell_corner_lon ! Longitude values of cell corners + + real (SCRIP_r8), intent(in) :: + & cell_center_lat, ! Latitude of cell center + & cell_center_lon, ! Longitude of cell center, + & inpt_lat, ! Latitude of inside point + & inpt_lon, ! Longitude of inside point + & outpt_lat, ! Latitude of outside point + & outpt_lon ! Longitude of outside point + + +!---------------------------------------------------------------------- +! +! Output variables +! +!---------------------------------------------------------------------- + + real (SCRIP_r8), intent(out) :: + & bpt_lat, ! Latitude of boundary point + & bpt_lon ! Longitude of boundary point + + integer (SCRIP_i4), intent(out) :: + & bedgeid ! ID of edge that point converged to + +!---------------------------------------------------------------------- +! +! Local variables +! +!---------------------------------------------------------------------- + + logical (SCRIP_logical) :: + & converged, + & lboundary, + & inpoly + + integer (SCRIP_i4) :: + & it + + real (SCRIP_r8) :: + & lat1, lon1, + & lat2, lon2, + & midlat, midlon + + bedgeid = 0 + + lat1 = inpt_lat + lon1 = inpt_lon + lat2 = outpt_lat + lon2 = outpt_lon + + + converged = .false. + it = 0 + do while (.not. converged) + + midlat = (lat1+lat2)/2.0 + if (abs(lon1-lon2) < pi) then + midlon = (lon1+lon2)/2.0 + else + midlon = (lon1+lon2)/2.0 - pi2 + endif + + + call ptincell(midlat, midlon, + & cell_add, ncorners, + & cell_corner_lat, cell_corner_lon, + & cell_center_lat, cell_center_lon, + & cell_grid_num, + & inpoly, lboundary, bedgeid) + + if (inpoly) then + lat1 = midlat + lon1 = midlon + else + lat2 = midlat + lon2 = midlon + endif + + if (abs(lat1-lat2) < tiny .and. + & abs(lon1-lon2) < tiny .and. lboundary) then + converged = .true. + endif + + if (it > 100) then + exit + endif + + it = it + 1 + enddo ! do while (not converged) + + + bpt_lat = midlat + bpt_lon = midlon + + end subroutine converge_to_bdry + + + + + end module scrip_remap_conservative + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 1de022012eabc02b979d247e7005fb035e459116 Mon Sep 17 00:00:00 2001 From: jcwarner-USGS Date: Fri, 20 Sep 2024 08:13:12 -0400 Subject: [PATCH 6/9] mv grid1/2 str/end integers outside of scripmpi --- model/src/SCRIP/scrip_remap_conservative.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/model/src/SCRIP/scrip_remap_conservative.F b/model/src/SCRIP/scrip_remap_conservative.F index 96c91d40a..593837c70 100755 --- a/model/src/SCRIP/scrip_remap_conservative.F +++ b/model/src/SCRIP/scrip_remap_conservative.F @@ -268,7 +268,6 @@ subroutine remap_conserv(l_master, l_test) ! !----------------------------------------------------------------------- #ifdef W3_SCRIPMPI - integer (SCRIP_i4) :: grid1_str, grid1_end, grid2_str, grid2_end integer (SCRIP_i4) :: IERR_MPI, IPROC, ratio integer (SCRIP_i4) :: j, ij, add1, add2, got_weight integer (SCRIP_i4) :: nlink, min_link, max_link @@ -278,6 +277,7 @@ subroutine remap_conserv(l_master, l_test) integer (SCRIP_i4), dimension(:), allocatable :: Arecv1 integer (SCRIP_i4), dimension(:), allocatable :: Arecv2 #endif + integer (SCRIP_i4) :: grid1_str, grid1_end, grid2_str, grid2_end integer (SCRIP_i4), parameter :: & phi_or_theta = 2 ! integrate w.r.t. phi (1) or theta (2) From 5d5c14fc68d8144aec921f961f9cbb0ede71e7c9 Mon Sep 17 00:00:00 2001 From: Matthew Masarik Date: Wed, 20 Nov 2024 16:33:43 +0000 Subject: [PATCH 7/9] ww3_ufs1.x/input/switch_MPI_OMPH: fix typo in switch --- regtests/ww3_ufs1.1/input/switch_MPI_OMPH | 2 +- regtests/ww3_ufs1.2/input/switch_MPI_OMPH | 2 +- regtests/ww3_ufs1.3/input/switch_MPI_OMPH | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/regtests/ww3_ufs1.1/input/switch_MPI_OMPH b/regtests/ww3_ufs1.1/input/switch_MPI_OMPH index 8be0a29a5..eb4b41e90 100644 --- a/regtests/ww3_ufs1.1/input/switch_MPI_OMPH +++ b/regtests/ww3_ufs1.1/input/switch_MPI_OMPH @@ -1 +1 @@ -NCO NOGRB DIST MPI OMPG OMGH SCRIP SCRIPNC WRST PR3 UQ FLX0 SEED ST4 STAB0 NL1 BT1 DB1 MLIM FLD2 TR0 BS0 RWND WNX1 WNT1 CRX1 CRT1 O0 O1 O2 O3 O4 O5 O6 O7 O14 O15 IC0 IS0 REF0 +NCO NOGRB DIST MPI OMPG OMPH SCRIP SCRIPNC WRST PR3 UQ FLX0 SEED ST4 STAB0 NL1 BT1 DB1 MLIM FLD2 TR0 BS0 RWND WNX1 WNT1 CRX1 CRT1 O0 O1 O2 O3 O4 O5 O6 O7 O14 O15 IC0 IS0 REF0 diff --git a/regtests/ww3_ufs1.2/input/switch_MPI_OMPH b/regtests/ww3_ufs1.2/input/switch_MPI_OMPH index 8be0a29a5..eb4b41e90 100644 --- a/regtests/ww3_ufs1.2/input/switch_MPI_OMPH +++ b/regtests/ww3_ufs1.2/input/switch_MPI_OMPH @@ -1 +1 @@ -NCO NOGRB DIST MPI OMPG OMGH SCRIP SCRIPNC WRST PR3 UQ FLX0 SEED ST4 STAB0 NL1 BT1 DB1 MLIM FLD2 TR0 BS0 RWND WNX1 WNT1 CRX1 CRT1 O0 O1 O2 O3 O4 O5 O6 O7 O14 O15 IC0 IS0 REF0 +NCO NOGRB DIST MPI OMPG OMPH SCRIP SCRIPNC WRST PR3 UQ FLX0 SEED ST4 STAB0 NL1 BT1 DB1 MLIM FLD2 TR0 BS0 RWND WNX1 WNT1 CRX1 CRT1 O0 O1 O2 O3 O4 O5 O6 O7 O14 O15 IC0 IS0 REF0 diff --git a/regtests/ww3_ufs1.3/input/switch_MPI_OMPH b/regtests/ww3_ufs1.3/input/switch_MPI_OMPH index 8be0a29a5..eb4b41e90 100644 --- a/regtests/ww3_ufs1.3/input/switch_MPI_OMPH +++ b/regtests/ww3_ufs1.3/input/switch_MPI_OMPH @@ -1 +1 @@ -NCO NOGRB DIST MPI OMPG OMGH SCRIP SCRIPNC WRST PR3 UQ FLX0 SEED ST4 STAB0 NL1 BT1 DB1 MLIM FLD2 TR0 BS0 RWND WNX1 WNT1 CRX1 CRT1 O0 O1 O2 O3 O4 O5 O6 O7 O14 O15 IC0 IS0 REF0 +NCO NOGRB DIST MPI OMPG OMPH SCRIP SCRIPNC WRST PR3 UQ FLX0 SEED ST4 STAB0 NL1 BT1 DB1 MLIM FLD2 TR0 BS0 RWND WNX1 WNT1 CRX1 CRT1 O0 O1 O2 O3 O4 O5 O6 O7 O14 O15 IC0 IS0 REF0 From 8b304320947ebf843871483942add33bb35236c8 Mon Sep 17 00:00:00 2001 From: Matthew Masarik Date: Wed, 20 Nov 2024 16:50:25 +0000 Subject: [PATCH 8/9] fix: OMP do statement --- model/src/SCRIP/scrip_remap_conservative.F | 32 ++++++++++------------ 1 file changed, 15 insertions(+), 17 deletions(-) diff --git a/model/src/SCRIP/scrip_remap_conservative.F b/model/src/SCRIP/scrip_remap_conservative.F index 593837c70..7e9e388de 100755 --- a/model/src/SCRIP/scrip_remap_conservative.F +++ b/model/src/SCRIP/scrip_remap_conservative.F @@ -354,9 +354,6 @@ subroutine remap_conserv(l_master, l_test) call timer_start(1) -C$OMP PARALLEL DEFAULT(SHARED) PRIVATE(grid1_add) NUM_THREADS(nthreads) - -C$OMP DO SCHEDULE(DYNAMIC) #ifdef W3_SCRIPMPI @@ -380,6 +377,10 @@ subroutine remap_conserv(l_master, l_test) grid1_str=1 grid1_end=grid1_size #endif + +C$OMP PARALLEL DEFAULT(SHARED) PRIVATE(grid1_add) NUM_THREADS(nthreads) + +C$OMP DO SCHEDULE(DYNAMIC) do grid1_add = grid1_str,grid1_end if (mod(grid1_add,progint) .eq. 0 .and. is_master) then @@ -389,7 +390,6 @@ subroutine remap_conserv(l_master, l_test) call cell_integrate(grid1_add, grid_num, phi_or_theta) end do ! do grid1_add=... - C$OMP END DO C$OMP END PARALLEL @@ -397,7 +397,7 @@ subroutine remap_conserv(l_master, l_test) #ifdef W3_SCRIPMPI ! -! Here we need to gather all the data processed and +! Here we need to gather all the data processed and ! send to each proc so they know the full data set. ! ! grid1 integrate @@ -461,7 +461,7 @@ subroutine remap_conserv(l_master, l_test) DO grid1_add=1,grid1_size Asend(grid1_add)=zero Arecv(grid1_add)=zero - END DO + END DO ! fill the send for this tile. DO grid1_add=grid1_str,grid1_end Asend(grid1_add)=grid1_centroid_lon(grid1_add) @@ -520,10 +520,6 @@ subroutine remap_conserv(l_master, l_test) call timer_start(2) -C$OMP PARALLEL DEFAULT(SHARED) PRIVATE(grid2_add) NUM_THREADS(nthreads) - -C$OMP DO SCHEDULE(DYNAMIC) - #ifdef W3_SCRIPMPI ! ! To do this in mpi, we will just break up the sweep loops into chunks. Then @@ -543,6 +539,9 @@ subroutine remap_conserv(l_master, l_test) grid2_str=1 grid2_end=grid2_size #endif +C$OMP PARALLEL DEFAULT(SHARED) PRIVATE(grid2_add) NUM_THREADS(nthreads) + +C$OMP DO SCHEDULE(DYNAMIC) do grid2_add = grid2_str,grid2_end if (mod(grid2_add,progint) .eq. 0 .and. is_master) then @@ -552,7 +551,6 @@ subroutine remap_conserv(l_master, l_test) call cell_integrate(grid2_add, grid_num, phi_or_theta) end do ! do grid2_add=... - C$OMP END DO C$OMP END PARALLEL @@ -562,7 +560,7 @@ subroutine remap_conserv(l_master, l_test) #ifdef W3_SCRIPMPI ! -! Here we need to gather all the data processed and +! Here we need to gather all the data processed and ! send to each proc so they know the full data set. ! ! grid2 integrate @@ -662,9 +660,9 @@ subroutine remap_conserv(l_master, l_test) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Both sweeps are now done. -! Here we need to gather all the data that was computed in +! Here we need to gather all the data that was computed in ! store_link_cnsrv. Then we allow the Master node to -! compute the rest after these steps. +! compute the rest after these steps. ! ! gather total number of links that were computed on each processor. ! @@ -766,8 +764,8 @@ subroutine remap_conserv(l_master, l_test) end do !----------------------------------------------------------------------- ! -! if the link does not yet exist, increment number of links and -! check to see if remap arrays need to be increased to accomodate +! if the link does not yet exist, increment number of links and +! check to see if remap arrays need to be increased to accomodate ! the new link. then store the link. ! !----------------------------------------------------------------------- @@ -792,7 +790,7 @@ subroutine remap_conserv(l_master, l_test) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! -! Now distribute: num_links_map1, grid1_add_map1, grid2_add_map1, +! Now distribute: num_links_map1, grid1_add_map1, grid2_add_map1, ! wts_map1, link_add1, link_add2, max_links_map1 ! ! send num_links_map1 From 60dac05f417b6155ae61a2f1ebe209a188957296 Mon Sep 17 00:00:00 2001 From: jcwarner-USGS Date: Mon, 9 Dec 2024 15:44:01 -0500 Subject: [PATCH 9/9] update switches.json for scripmpi --- model/src/cmake/switches.json | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/model/src/cmake/switches.json b/model/src/cmake/switches.json index 999f46e5c..5431947d4 100644 --- a/model/src/cmake/switches.json +++ b/model/src/cmake/switches.json @@ -45,11 +45,12 @@ }, { "name": "scripmpi", - "num_switches": "upto2", - "description": "", + "num_switches": "upto1", + "description": "use MPI parallelism for SCRIP regridding", "valid-options": [ { - "name": "SCRIPMPI" + "name": "SCRIPMPI", + "requires": ["SCRIP", "MPI"] } ] },