Data Types
type	weight_data

Functions/Subroutines
subroutine	scrip_clear

subroutine	scrip (src_num, dst_num, l_master, l_read, l_test)

subroutine	scrip_driverexit (errorCode, errormsg)

subroutine	sort_add_v2 (add1, add2, weights)

Variables
type(weight_data), dimension(:), allocatable	wgtdata

Function/Subroutine Documentation

◆ scrip()

subroutine scrip_interface::scrip	(	integer (scrip_i4), intent(in)	src_num,
		integer (scrip_i4), intent(in)	dst_num,
		logical (scrip_logical), intent(in)	l_master,
		logical( scrip_logical), intent(in)	l_read,
		logical(scrip_logical), intent(in)	l_test
	)

Definition at line 330 of file scrip_interface.F90.

  
     !-----------------------------------------------------------------------
  
     use scrip_kindsmod                  ! module defining data types
     use scrip_constants                  ! module for common constants
     use scrip_iounitsmod                    ! I/O unit manager
     use scrip_timers                     ! CPU timers
     use scrip_grids                      ! module with grid information
     use scrip_remap_vars                 ! common remapping variables
     use scrip_remap_conservative         ! routines for conservative remap
  
 #ifdef W3_SCRIPNC
     use scrip_remap_write                ! routines for remap output
     use scrip_remap_read                 ! routines for remap input
 #endif
  
     use scrip_errormod
  
     implicit none
  
     !-----------------------------------------------------------------------
     !
     !     input variables formerly part of namelist
     !
     !-----------------------------------------------------------------------
  
     character (SCRIP_charLength) :: &
          interp_file1,& ! filename for output remap data (map1)
          interp_file2,& ! filename for output remap data (map2)
          map1_name,   & ! name for mapping from grid1 to grid2
          map2_name,   & ! name for mapping from grid2 to grid1
          map_method,  & ! choice for mapping method
          normalize_opt,&! option for normalizing weights
          output_opt    ! option for output conventions
  
     integer (SCRIP_i4) :: &
          nmap          ! number of mappings to compute (1 or 2)
  
     !-----------------------------------------------------------------------
     !
     !     input variables not part of namelist
     !
     !-----------------------------------------------------------------------
  
     integer (SCRIP_i4), intent(in)      :: dst_num   ! number of destination grid GDST
     integer (SCRIP_i4), intent(in)      :: src_num   ! number of source grid GSRC
     logical (SCRIP_Logical), intent(in) :: l_master  ! Am I the master processor (do I/O)?
     logical( SCRIP_Logical), intent(in) :: l_read    ! Do I read the remap file?
     logical(SCRIP_Logical), intent(in) :: l_test     ! Whether to include test output
     ! in subroutines
  
     !-----------------------------------------------------------------------
     !
     !     local variables
     !
     !-----------------------------------------------------------------------
  
     integer (SCRIP_i4) :: n, &   ! dummy counter
          iunit  ! unit number for namelist file
  
     integer (SCRIP_i4) :: &
          errorCode      ! error flag
  
     character (12), parameter :: &
          rtnName = 'SCRIP_driver'
  
 #ifdef W3_SCRIPNC
     character (LEN=3) :: cdst  ! 3 character number of destination map
     character (LEN=3) :: csrc  ! 3 character number of source map
 #endif
 #ifdef W3_T38
     CHARACTER (LEN=10) :: CDATE_TIME(3)
     INTEGER            :: DATE_TIME(8)
     INTEGER            :: ELAPSED_TIME, BEG_TIME, END_TIME
 #endif
  
     !-----------------------------------------------------------------------
     !
     !     initialize timers and errorcode
     !
     !-----------------------------------------------------------------------
  
 #ifdef W3_T38
     if(l_master)write(scrip_stdout,*)'subroutine scrip'
 #endif
  
     call timers_init
     do n=1,max_timers
       call timer_clear(n)
     end do
  
     errorcode = scrip_success
  
     !-----------------------------------------------------------------------
     !
     !     set variables that were previously read in as a namelist
     !
     !-----------------------------------------------------------------------
  
     num_maps = 1
 #ifdef W3_SCRIPNC
     !     Note: Only master does I/O, but all processors need to know about
     !     file existence
     interp_file1 = "rmp_src_to_dst_conserv_XXX_XXX.nc"
     interp_file2 = 'not_used.nc'
     map1_name = 'source to destination Conservative Mapping'
     map2_name = 'map not used'
     write(cdst, "(i3.3)") dst_num
     write(csrc, "(i3.3)") src_num
     interp_file1(24:26) = csrc
     interp_file1(28:30) = cdst
 #endif
  
     map_method = 'conservative'
     normalize_opt = 'fracarea'
     output_opt = 'scrip'
     restrict_type = 'latitude'
     num_srch_bins = 90
     luse_grid1_area = .false.
     luse_grid2_area = .false.
     npseg=11 ! or num_polar_segs
     north_thresh=1.5_scrip_r8 ! or npole_threshold
     south_thresh=-1.5_scrip_r8 ! or spole_threshold
     nthreads=2 ! or num_threads
  
     select case(map_method)
     case ('conservative')
       map_type = map_type_conserv
       luse_grid_centers = .false.
     case ('bilinear')
       map_type = map_type_bilinear
       luse_grid_centers = .true.
     case ('bicubic')
       map_type = map_type_bicubic
       luse_grid_centers = .true.
     case ('distwgt')
       map_type = map_type_distwgt
       luse_grid_centers = .true.
     case ('particle')
       map_type = map_type_particle
       luse_grid_centers = .false.
     case default
       call scrip_errorset(errorcode, rtnname, 'unknown mapping method')
       call scrip_driverexit(errorcode, 'unknown mapping method')
     end select
  
     select case(normalize_opt(1:4))
     case ('none')
       norm_opt = norm_opt_none
     case ('frac')
       norm_opt = norm_opt_frcarea
     case ('dest')
       norm_opt = norm_opt_dstarea
     case default
       call scrip_errorset(errorcode, rtnname, 'unknown normalization option')
       call scrip_driverexit(errorcode, 'unknown normalization option')
     end select
  
     !-----------------------------------------------------------------------
     !
     !     initialize grid information for both grids
     !
     !-----------------------------------------------------------------------
  
 #ifdef W3_T38
     if(l_master)write(scrip_stdout,*)'calling grid_init'
 #endif
  
     call grid_init( errorcode,l_master,l_test)
  
 #ifdef W3_T38
     if(l_master)write(scrip_stdout, *) 'Computing remappings between: ',grid1_name
     if(l_master)write(scrip_stdout, *) '                         and  ',grid2_name
 #endif
  
     !-----------------------------------------------------------------------
     !
     !     initialize some remapping variables.
     !
     !-----------------------------------------------------------------------
  
     call init_remap_vars
  
     !-----------------------------------------------------------------------
     !
     !     call appropriate interpolation setup routine based on type of
     !     remapping requested. or read in remapping data.
 #ifdef W3_SCRIPNC
     !or, read in remapping data.
 #endif
     !
     !-----------------------------------------------------------------------
  
 #ifdef W3_T38
     call date_and_time (cdate_time(1), cdate_time(2), cdate_time(3), date_time)
     beg_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8)
 #endif
  
 #ifdef W3_SCRIPNC
     if (l_read) then
       if(l_master)write(scrip_stdout, *) 'Reading remapping data from ', interp_file1
       call read_remap_ww3(map1_name, interp_file1, errorcode)
 #endif
 #ifdef W3_T38
       call date_and_time (cdate_time(1), cdate_time(2), cdate_time(3), date_time)
       end_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8)
       elapsed_time = end_time - beg_time
       write(0,*) "SCRIP: READING ", elapsed_time, " MSEC"
 #endif
 #ifdef W3_SCRIPNC
     else
 #endif
       select case(map_type)
       case(map_type_conserv)
 #ifdef W3_T38
         if(l_master)write(scrip_stdout,*)'calling remap_conserv'
 #endif
         call remap_conserv(l_master,l_test)
 #ifdef W3_T38
         if(l_master)write(scrip_stdout,*)'back from remap_conserv'
         call date_and_time (cdate_time(1), cdate_time(2), cdate_time(3), date_time)
         end_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8)
         elapsed_time = end_time - beg_time
         write(0,*) "SCRIP: CALCULATING ", elapsed_time, " MSEC"
 #endif
       case default
         call scrip_errorset(errorcode, rtnname, 'Invalid Map Type')
         call scrip_driverexit(errorcode, 'Invalid Map Type')
       end select
  
       !-----------------------------------------------------------------------
       !
       !     reduce size of remapping arrays
       !
       !-----------------------------------------------------------------------
  
 #ifdef W3_T38
       call date_and_time (cdate_time(1), cdate_time(2), cdate_time(3), date_time)
       beg_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8)
 #endif
  
       if (num_links_map1 /= max_links_map1) then
         call resize_remap_vars(1, num_links_map1-max_links_map1)
       endif
       if ((num_maps > 1) .and. (num_links_map2 /= max_links_map2)) then
         call resize_remap_vars(2, num_links_map2-max_links_map2)
       endif
  
       call sort_add_v2(grid2_add_map1, grid1_add_map1, wts_map1)
  
       !-----------------------------------------------------------------------
       !
 #ifdef W3_SCRIPNC
       !     write remapping info to a file.
 #endif
       !
       !-----------------------------------------------------------------------
  
 #ifdef W3_SCRIPNC
       if (l_master) then
         write(scrip_stdout, *) 'Writing remapping data to ', interp_file1
       endif
 #endif
  
 #ifdef W3_T38
       call date_and_time (cdate_time(1), cdate_time(2), cdate_time(3), date_time)
       end_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8)
       elapsed_time = end_time - beg_time
       write(0,*) "SCRIP: RESIZING ", elapsed_time, " MSEC"
       call date_and_time (cdate_time(1), cdate_time(2), cdate_time(3), date_time)
       beg_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8)
 #endif
  
       ! Use  write_remap if you want the extra variables in the .nc files for diagnostics
       ! Use  write_remap_ww3 if you don't want any extra variables in the .nc files
  
 #ifdef W3_SCRIPNC
       if(l_test)then
         call write_remap(map1_name, map2_name, interp_file1, interp_file2, &
              output_opt, l_master, errorcode)
       else
         call write_remap_ww3(map1_name, interp_file1, output_opt, &
              l_master, errorcode)
       endif
 #endif
  
 #ifdef W3_SCRIPNC
     end if
 #endif
  
     !-----------------------------------------------------------------------
  

Referenced by wmscrpmd::scrip_wrapper().

◆ scrip_clear()

subroutine scrip_interface::scrip_clear

Definition at line 82 of file scrip_interface.F90.

     !#######################################################################
  
     !  1. Original author :
     !
     !     Erick Rogers, NRL
     !
     !  2. Last update :
     !
     !     See revisions.
     !
     !  3. Revisions :
     !
     !     5-May-2011 : Origination                         ( version 4.01 )
     !
     !  4. Copyright :
     !
     !  5. Purpose :
     !
     !     "Clear" all variables declared at module level of SCRIP routines
     !     (clear "common block" equivalent)
     !
     !  6. Method :
     !
     !     rules:
     !        - if not an array (scalar), set to zero or other start value
     !        - if dimensioned array, set to zero
     !        - if allocatable array, deallocate
     !        - private variables: ignore, since we would need to
     !             make them public in order to clear them, which may do more
     !             harm than good.
     !
     !  7. Parameters, Variables and types :
     !
     !  8. Called by :
     !
     !     Subroutine SCRIP_interface
     !
     !  9. Subroutines and functions used :
     !
     !     None
     !
     ! 10. Error messages:
     !
     ! 11. Remarks :
     !
     !     We "clear" all variables with "save" attribute,
     !     both "module variables" and "subroutine variables"
     !     including all variables that are initialized with a value
     !     in the type declaration, e.g. "real :: x=5.0"
     !
     ! 12. Structure :
     !
     ! 13. Switches :
     !
     ! 14. Source code :
  
     use scrip_kindsmod
     use scrip_timers
     use scrip_remap_vars
     use scrip_remap_conservative
     use scrip_iounitsmod
     use scrip_grids
  
     implicit none
  
     call timers_init ! takes care of all variables in timers.f
  
     !.....scrip_remap_vars.f :
     max_links_map1=0
     num_links_map1=0
     max_links_map2=0
     num_links_map2=0
     num_maps=0
     num_wts=0
     map_type=0
     norm_opt=0
     resize_increment=0
     if(allocated(grid1_add_map1))deallocate(grid1_add_map1)
     if(allocated(grid2_add_map1))deallocate(grid2_add_map1)
     if(allocated(grid1_add_map2))deallocate(grid1_add_map2)
     if(allocated(grid2_add_map2))deallocate(grid2_add_map2)
     if(allocated(wts_map1))deallocate(wts_map1)
     if(allocated(wts_map2))deallocate(wts_map2)
  
     !.....remap_conserv.f :
     !.....scalars:
     first_call_store_link_cnsrv = .true.
     first_call_locate_segstart= .true.
     first_call_locate_point= .true.
     first_call_get_srch_cells=.true.
     first_call_find_adj_cell=.true.
     avoid_pole_count = 0
     avoid_pole_offset = tiny
     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
     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
     srch_corners_locate_point=0
     srch_corners_find_adj_cell=0
     srch_corners_locate_segstart=0
     srch_corners_loc_get_srch_cells=0
     num_srch_cells_loc_get_srch_cells=0
     num_srch_cells_find_adj_cell=0
     last_cell_add_get_srch_cells=0
     last_cell_grid_num_get_srch_cells=0
     last_srch_grid_num_get_srch_cells=0
     last_cell_find_adj_cell=0
     last_cell_grid_num_find_adj_cell=0
     !.....arrays :
     if(allocated(link_add1))deallocate(link_add1)
     if(allocated(link_add2))deallocate(link_add2)
  
     if(allocated(srch_add_loc_get_srch_cells))deallocate(srch_add_loc_get_srch_cells)
     if(allocated(srch_corner_lat_loc_get_srch_cells))deallocate(srch_corner_lat_loc_get_srch_cells)
     if(allocated(srch_corner_lon_loc_get_srch_cells))deallocate(srch_corner_lon_loc_get_srch_cells)
     if(allocated(srch_center_lat_loc_get_srch_cells))deallocate(srch_center_lat_loc_get_srch_cells)
     if(allocated(srch_center_lon_loc_get_srch_cells))deallocate(srch_center_lon_loc_get_srch_cells)
  
     if(allocated(srch_add_find_adj_cell))deallocate(srch_add_find_adj_cell)
     if(allocated(srch_corner_lat_find_adj_cell))deallocate(srch_corner_lat_find_adj_cell)
     if(allocated(srch_corner_lon_find_adj_cell))deallocate(srch_corner_lon_find_adj_cell)
     if(allocated(srch_center_lat_find_adj_cell))deallocate(srch_center_lat_find_adj_cell)
     if(allocated(srch_center_lon_find_adj_cell))deallocate(srch_center_lon_find_adj_cell)
  
     if(allocated(srch_add_locate_segstart))deallocate(srch_add_locate_segstart)
     if(allocated(srch_corner_lat_locate_segstart))deallocate(srch_corner_lat_locate_segstart)
     if(allocated(srch_corner_lon_locate_segstart))deallocate(srch_corner_lon_locate_segstart)
     if(allocated(srch_center_lat_locate_segstart))deallocate(srch_center_lat_locate_segstart)
     if(allocated(srch_center_lon_locate_segstart))deallocate(srch_center_lon_locate_segstart)
  
     if(allocated(srch_add_locate_point))deallocate(srch_add_locate_point)
     if(allocated(srch_corner_lat_locate_point))deallocate(srch_corner_lat_locate_point)
     if(allocated(srch_corner_lon_locate_point))deallocate(srch_corner_lon_locate_point)
     if(allocated(srch_center_lat_locate_point))deallocate(srch_center_lat_locate_point)
     if(allocated(srch_center_lon_locate_point))deallocate(srch_center_lon_locate_point)
  
     !.....scrip_grids.f :
     grid1_size=0
     grid2_size=0
     grid1_rank=0
     grid2_rank=0
     grid1_corners=0
     grid2_corners=0
     grid1_name=''
     grid2_name=''
     grid1_units=''
     grid2_units=''
     luse_grid_centers=.false.
     luse_grid1_area=.false.
     luse_grid2_area=.false.
     restrict_type=''
     num_srch_bins=0
     if(allocated(bin_addr1))deallocate(bin_addr1)
     if(allocated(bin_addr2))deallocate(bin_addr2)
     if(allocated(bin_lats))deallocate(bin_lats)
     if(allocated(bin_lons))deallocate(bin_lons)
     if(allocated(grid1_dims))deallocate(grid1_dims)
     if(allocated(grid2_dims))deallocate(grid2_dims)
     if(allocated(grid1_mask))deallocate(grid1_mask)
     if(allocated(grid2_mask))deallocate(grid2_mask)
     if(allocated(grid1_center_lat))deallocate(grid1_center_lat)
     if(allocated(grid1_center_lon))deallocate(grid1_center_lon)
     if(allocated(grid2_center_lat))deallocate(grid2_center_lat)
     if(allocated(grid2_center_lon))deallocate(grid2_center_lon)
     if(allocated(grid1_area))deallocate(grid1_area)
     if(allocated(grid2_area))deallocate(grid2_area)
     if(allocated(grid1_area_in))deallocate(grid1_area_in)
     if(allocated(grid2_area_in))deallocate(grid2_area_in)
     if(allocated(grid1_frac))deallocate(grid1_frac)
     if(allocated(grid2_frac))deallocate(grid2_frac)
     if(allocated(grid1_corner_lat))deallocate(grid1_corner_lat)
     if(allocated(grid1_corner_lon))deallocate(grid1_corner_lon)
     if(allocated(grid2_corner_lat))deallocate(grid2_corner_lat)
     if(allocated(grid2_corner_lon))deallocate(grid2_corner_lon)
     if(allocated(grid1_bound_box))deallocate(grid1_bound_box)
     if(allocated(grid2_bound_box))deallocate(grid2_bound_box)
     if(allocated(special_polar_cell1))deallocate(special_polar_cell1)
     if(allocated(special_polar_cell2))deallocate(special_polar_cell2)
     if(allocated(grid1_centroid_lat))deallocate(grid1_centroid_lat)
     if(allocated(grid1_centroid_lon))deallocate(grid1_centroid_lon)
     if(allocated(grid2_centroid_lat))deallocate(grid2_centroid_lat)
     if(allocated(grid2_centroid_lon))deallocate(grid2_centroid_lon)
  
     !#######################################################################

Referenced by wmscrpmd::scrip_wrapper().

◆ scrip_driverexit()

subroutine scrip_interface::scrip_driverexit	(	integer (scrip_i4), intent(in)	errorCode,
		character(), intent(in)	errormsg
	)

Definition at line 626 of file scrip_interface.F90.

  
     ! !DESCRIPTION:
     !  This routine exits the SCRIP driver program. It first calls the
     !  SCRIP error print function to print any errors encountered and then
     !  exits the message environment before stopping.
     !
     ! !USES:
  
     use scrip_kindsmod
  
     ! !INPUT PARAMETERS:
  
     integer (SCRIP_i4), intent(in) :: &
          errorCode        ! error flag to detect any errors encountered
  
     CHARACTER*(*), INTENT(IN)  :: errormsg
     !-----------------------------------------------------------------------
     !
     !  call SCRIP error print function to output any logged errors that
     !  were encountered during execution.  Then stop.
     !
     !-----------------------------------------------------------------------
  
     write(*,*)'error encountered : ',errorcode
     write(*,*)errormsg
  
     stop
  
     !-----------------------------------------------------------------------
  

Referenced by scrip().

◆ sort_add_v2()

subroutine scrip_interface::sort_add_v2	(	integer (scrip_i4), dimension(:), intent(inout)	add1,
		integer (scrip_i4), dimension(:), intent(inout)	add2,
		real (scrip_r8), dimension(:,:), intent(inout)	weights
	)

Definition at line 660 of file scrip_interface.F90.

     !#######################################################################
  
     !-----------------------------------------------------------------------
     !
     !     this routine sorts address and weight arrays based on the
     !     destination address with the source address as a secondary
     !     sorting criterion.  the method is a standard heap sort.
     !
     !     sort_add_v2 is identical to subroutine sort_add, but is moved into
     !     scrip_interface.ftn and converted to f90 format (line continuations)
     !
     !-----------------------------------------------------------------------
  
     implicit none
  
     !-----------------------------------------------------------------------
     !
     !     Input and Output arrays
     !
     !-----------------------------------------------------------------------
  
     integer (SCRIP_i4), intent(inout), dimension(:) :: &
          add1,  &    ! destination address array (num_links)
          add2        ! source      address array
  
     real (SCRIP_r8), intent(inout), dimension(:,:) :: &
          weights     ! remapping weights (num_wts, num_links)
  
     !-----------------------------------------------------------------------
     !
     !     local variables
     !
     !-----------------------------------------------------------------------
  
     integer (SCRIP_i4) ::   &
          num_links,         & ! num of links for this mapping
          num_wts,           & ! num of weights for this mapping
          add1_tmp, add2_tmp,& ! temp for addresses during swap
          lvl, final_lvl,    & ! level indexes for heap sort levels
          chk_lvl1, chk_lvl2, max_lvl
  
     real (SCRIP_r8), dimension(SIZE(weights,DIM=1)) :: &
          wgttmp              ! temp for holding wts during swap
  
     !-----------------------------------------------------------------------
     !
     !     determine total number of links to sort and number of weights
     !
     !-----------------------------------------------------------------------
  
     num_links = SIZE(add1)
     num_wts   = SIZE(weights, dim=1)
  
     !-----------------------------------------------------------------------
     !
     !     start at the lowest level (N/2) of the tree and sift lower
     !     values to the bottom of the tree, promoting the larger numbers
     !
     !-----------------------------------------------------------------------
  
     do lvl=num_links/2,1,-1
  
       final_lvl = lvl
       add1_tmp = add1(lvl)
       add2_tmp = add2(lvl)
       wgttmp(:) = weights(:,lvl)
  
       !***
       !*** loop until proper level is found for this link, or reach
       !*** bottom
       !***
  
       sift_loop1: do
  
         !***
         !*** find the largest of the two daughters
         !***
  
         chk_lvl1 = 2*final_lvl
         chk_lvl2 = 2*final_lvl+1
         if (chk_lvl1 .EQ. num_links) chk_lvl2 = chk_lvl1
  
         if ((add1(chk_lvl1) >  add1(chk_lvl2)) .OR.    &
              ((add1(chk_lvl1) == add1(chk_lvl2)) .AND. &
              (add2(chk_lvl1) >  add2(chk_lvl2)))) then
           max_lvl = chk_lvl1
         else
           max_lvl = chk_lvl2
         endif
  
         !***
         !*** if the parent is greater than both daughters,
         !*** the correct level has been found
         !***
  
         if ((add1_tmp .GT. add1(max_lvl)) .OR.    &
              ((add1_tmp .EQ. add1(max_lvl)) .AND. &
              (add2_tmp .GT. add2(max_lvl)))) then
           add1(final_lvl) = add1_tmp
           add2(final_lvl) = add2_tmp
           weights(:,final_lvl) = wgttmp(:)
           exit sift_loop1
  
           !***
           !*** otherwise, promote the largest daughter and push
           !*** down one level in the tree.  if haven't reached
           !*** the end of the tree, repeat the process.  otherwise
           !*** store last values and exit the loop
           !***
  
         else
           add1(final_lvl) = add1(max_lvl)
           add2(final_lvl) = add2(max_lvl)
           weights(:,final_lvl) = weights(:,max_lvl)
  
           final_lvl = max_lvl
           if (2*final_lvl > num_links) then
             add1(final_lvl) = add1_tmp
             add2(final_lvl) = add2_tmp
             weights(:,final_lvl) = wgttmp(:)
             exit sift_loop1
           endif
         endif
       end do sift_loop1
     end do
  
     !-----------------------------------------------------------------------
     !
     !     now that the heap has been sorted, strip off the top (largest)
     !     value and promote the values below
     !
     !-----------------------------------------------------------------------
  
     do lvl=num_links,3,-1
  
       !***
       !*** move the top value and insert it into the correct place
       !***
  
       add1_tmp = add1(lvl)
       add1(lvl) = add1(1)
  
       add2_tmp = add2(lvl)
       add2(lvl) = add2(1)
  
       wgttmp(:) = weights(:,lvl)
       weights(:,lvl) = weights(:,1)
  
       !***
       !*** as above this loop sifts the tmp values down until proper
       !*** level is reached
       !***
  
       final_lvl = 1
  
       sift_loop2: do
  
         !***
         !*** find the largest of the two daughters
         !***
  
         chk_lvl1 = 2*final_lvl
         chk_lvl2 = 2*final_lvl+1
         if (chk_lvl2 >= lvl) chk_lvl2 = chk_lvl1
  
         if ((add1(chk_lvl1) >  add1(chk_lvl2)) .OR.    &
              ((add1(chk_lvl1) == add1(chk_lvl2)) .AND. &
              (add2(chk_lvl1) >  add2(chk_lvl2)))) then
           max_lvl = chk_lvl1
         else
           max_lvl = chk_lvl2
         endif
  
         !***
         !*** if the parent is greater than both daughters,
         !*** the correct level has been found
         !***
  
         if ((add1_tmp >  add1(max_lvl)) .OR.    &
              ((add1_tmp == add1(max_lvl)) .AND. &
              (add2_tmp >  add2(max_lvl)))) then
           add1(final_lvl) = add1_tmp
           add2(final_lvl) = add2_tmp
           weights(:,final_lvl) = wgttmp(:)
           exit sift_loop2
  
           !***
           !*** otherwise, promote the largest daughter and push
           !*** down one level in the tree.  if haven't reached
           !*** the end of the tree, repeat the process.  otherwise
           !*** store last values and exit the loop
           !***
  
         else
           add1(final_lvl) = add1(max_lvl)
           add2(final_lvl) = add2(max_lvl)
           weights(:,final_lvl) = weights(:,max_lvl)
  
           final_lvl = max_lvl
           if (2*final_lvl >= lvl) then
             add1(final_lvl) = add1_tmp
             add2(final_lvl) = add2_tmp
             weights(:,final_lvl) = wgttmp(:)
             exit sift_loop2
           endif
         endif
       end do sift_loop2
     end do
  
     !***
     !*** swap the last two entries
     !***
  
  
     add1_tmp = add1(2)
     add1(2)  = add1(1)
     add1(1)  = add1_tmp
  
     add2_tmp = add2(2)
     add2(2)  = add2(1)
     add2(1)  = add2_tmp
  
     wgttmp(:)   = weights(:,2)
     weights(:,2) = weights(:,1)
     weights(:,1) = wgttmp(:)
  
     !#######################################################################

Referenced by scrip().

Variable Documentation

◆ wgtdata

type(weight_data), dimension(:), allocatable scrip_interface::wgtdata

Definition at line 73 of file scrip_interface.F90.

73 type(weight_data), allocatable :: wgtdata(:)

Referenced by wmscrpmd::scrip_wrapper(), and wmgridmd::wmghgh().

Data Types

Functions/Subroutines