WW3/scrip__remap__vars_8f_source.html

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!

!     this module contains necessary variables for remapping between

!     two grids.  also routines for resizing and initializing these

!     variables.

!

!-----------------------------------------------------------------------

!

!     CVS:$Id: remap_vars.f,v 1.5 2000/04/19 21:56:26 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.

!

!***********************************************************************


      module scrip_remap_vars


      use scrip_kindsmod ! defines common data types

      use scrip_constants

      use scrip_grids


      implicit none


!-----------------------------------------------------------------------

!

!     module variables

!

!-----------------------------------------------------------------------


      integer (SCRIP_i4), parameter ::

     &      norm_opt_none    = 1

     &,     norm_opt_dstarea = 2

     &,     norm_opt_frcarea = 3


      integer (SCRIP_i4), parameter ::

     &      map_type_conserv  = 1

     &,     map_type_bilinear = 2

     &,     map_type_bicubic  = 3

     &,     map_type_distwgt  = 4

     &,     map_type_particle = 5


      integer (SCRIP_i4), save ::

     &      max_links_map1  ! current size of link arrays

     &,     num_links_map1  ! actual number of links for remapping

     &,     max_links_map2  ! current size of link arrays

     &,     num_links_map2  ! actual number of links for remapping

     &,     num_maps        ! num of remappings for this grid pair

     &,     num_wts         ! num of weights used in remapping

     &,     map_type        ! identifier for remapping method

     &,     norm_opt        ! option for normalization (conserv only)

     &,     resize_increment ! default amount to increase array size


      integer (SCRIP_i4), dimension(:), allocatable, save ::

     &      grid1_add_map1, ! grid1 address for each link in mapping 1

     &      grid2_add_map1, ! grid2 address for each link in mapping 1

     &      grid1_add_map2, ! grid1 address for each link in mapping 2

     &      grid2_add_map2  ! grid2 address for each link in mapping 2


      real (scrip_r8), dimension(:,:), allocatable, save ::

     &      wts_map1, ! map weights for each link (num_wts,max_links)

     &      wts_map2  ! map weights for each link (num_wts,max_links)


      real (kind = scrip_r8) :: frac_lowest,frac_highest

      real (kind = scrip_r8) :: wt_lowest,wt_highest


!***********************************************************************


      contains


!***********************************************************************


      subroutine init_remap_vars


!-----------------------------------------------------------------------

!

!     this routine initializes some variables and provides an initial

!     allocation of arrays (fairly large so frequent resizing

!     unnecessary).

!

!-----------------------------------------------------------------------


!-----------------------------------------------------------------------

!

!     determine the number of weights

!

!-----------------------------------------------------------------------


      select case (map_type)

      case(map_type_conserv)

        num_wts = 3

      case(map_type_bilinear)

        num_wts = 1

      case(map_type_bicubic)

        num_wts = 4

      case(map_type_distwgt)

        num_wts = 1

      case(map_type_particle)

        num_wts = 1

      end select


!-----------------------------------------------------------------------

!

!     initialize num_links and set max_links to four times the largest

!     of the destination grid sizes initially (can be changed later).

!     set a default resize increment to increase the size of link

!     arrays if the number of links exceeds the initial size

!

!-----------------------------------------------------------------------


      num_links_map1 = 0

      max_links_map1 = 4*grid2_size

      if (num_maps > 1) then

        num_links_map2 = 0

        max_links_map1 = max(4*grid1_size,4*grid2_size)

        max_links_map2 = max_links_map1

      endif


      resize_increment = 0.1*max(grid1_size,grid2_size)


!-----------------------------------------------------------------------

!

!     allocate address and weight arrays for mapping 1

!

!-----------------------------------------------------------------------


      allocate (grid1_add_map1(max_links_map1),

     &          grid2_add_map1(max_links_map1),

     &          wts_map1(num_wts, max_links_map1))


!-----------------------------------------------------------------------

!

!     allocate address and weight arrays for mapping 2 if necessary

!

!-----------------------------------------------------------------------


      if (num_maps > 1) then

        allocate (grid1_add_map2(max_links_map2),

     &            grid2_add_map2(max_links_map2),

     &            wts_map2(num_wts, max_links_map2))

      endif


!-----------------------------------------------------------------------


      end subroutine init_remap_vars


!***********************************************************************


      subroutine resize_remap_vars(nmap, increment)


!-----------------------------------------------------------------------

!

!     this routine resizes remapping arrays by increasing(decreasing)

!     the max_links by increment

!

!-----------------------------------------------------------------------


!-----------------------------------------------------------------------

!

!     input variables

!

!-----------------------------------------------------------------------


      integer (SCRIP_i4), intent(in) ::

     &     nmap,      ! identifies which mapping array to resize

     &     increment  ! the number of links to add(subtract) to arrays


!-----------------------------------------------------------------------

!

!     local variables

!

!-----------------------------------------------------------------------


      integer (SCRIP_i4) ::

     &   ierr,     ! error flag

     &   mxlinks   ! size of link arrays


      integer (SCRIP_i4), dimension(:), allocatable ::

     &   add1_tmp, ! temp array for resizing address arrays

     &   add2_tmp  ! temp array for resizing address arrays


      real (SCRIP_r8), dimension(:,:), allocatable ::

     &   wts_tmp   ! temp array for resizing weight arrays


!-----------------------------------------------------------------------

!

!     resize map 1 arrays if required.

!

!-----------------------------------------------------------------------


      select case (nmap)

      case(1)


        !***

        !*** allocate temporaries to hold original values

        !***


        mxlinks = size(grid1_add_map1)

        allocate (add1_tmp(mxlinks), add2_tmp(mxlinks),

     &            wts_tmp(num_wts,mxlinks))


        add1_tmp = grid1_add_map1

        add2_tmp = grid2_add_map1

        wts_tmp  = wts_map1


        !***

        !*** deallocate originals and increment max_links then

        !*** reallocate arrays at new size

        !***


        deallocate (grid1_add_map1, grid2_add_map1, wts_map1)

        max_links_map1 = mxlinks + increment

        allocate (grid1_add_map1(max_links_map1),

     &            grid2_add_map1(max_links_map1),

     &            wts_map1(num_wts,max_links_map1))


        !***

        !*** restore original values from temp arrays and

        !*** deallocate temps

        !***


        mxlinks = min(mxlinks, max_links_map1)

        grid1_add_map1(1:mxlinks) = add1_tmp(1:mxlinks)

        grid2_add_map1(1:mxlinks) = add2_tmp(1:mxlinks)

        wts_map1(:,1:mxlinks) = wts_tmp(:,1:mxlinks)

        deallocate(add1_tmp, add2_tmp, wts_tmp)


!-----------------------------------------------------------------------

!

!     resize map 2 arrays if required.

!

!-----------------------------------------------------------------------


      case(2)


        !***

        !*** allocate temporaries to hold original values

        !***


        mxlinks = size(grid1_add_map2)

        allocate (add1_tmp(mxlinks), add2_tmp(mxlinks),

     &            wts_tmp(num_wts,mxlinks),stat=ierr)

        if (ierr .ne. 0) then

          print *,'error allocating temps in resize: ',ierr

          stop

        endif


        add1_tmp = grid1_add_map2

        add2_tmp = grid2_add_map2

        wts_tmp  = wts_map2


        !***

        !*** deallocate originals and increment max_links then

        !*** reallocate arrays at new size

        !***


        deallocate (grid1_add_map2, grid2_add_map2, wts_map2)

        max_links_map2 = mxlinks + increment

        allocate (grid1_add_map2(max_links_map2),

     &            grid2_add_map2(max_links_map2),

     &            wts_map2(num_wts,max_links_map2),stat=ierr)

        if (ierr .ne. 0) then

          print *,'error allocating new arrays in resize: ',ierr

          stop

        endif


        !***

        !*** restore original values from temp arrays and

        !*** deallocate temps

        !***


        mxlinks = min(mxlinks, max_links_map2)

        grid1_add_map2(1:mxlinks) = add1_tmp(1:mxlinks)

        grid2_add_map2(1:mxlinks) = add2_tmp(1:mxlinks)

        wts_map2(:,1:mxlinks) = wts_tmp(:,1:mxlinks)

        deallocate(add1_tmp, add2_tmp, wts_tmp)


      end select


!-----------------------------------------------------------------------


      end subroutine resize_remap_vars


!***********************************************************************


      end module scrip_remap_vars


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!