#include "forttype.h" MODULE mod_spec_int1 USE mod_parameters USE mod_template USE mod_process USE mod_mem_alloc IMPLICIT NONE CONTAINS !---------------------------------------------------------------------------------- SUBROUTINE add_template_spec_int1 USE mod_lunits IMPLICIT NONE TYPE (template), POINTER :: add CHARACTER, DIMENSION(:), ALLOCATABLE :: sizestring __INTEGER :: ierr, ierr1, ierr2, ierr3, ierr4, ierr5 ALLOCATE( add , stat=ierr) IF (ierr /= 0) then write(lu_log,*) " add_template_spec_int1 : allocation failed" call peg_error('Bad allocate stat') end if #ifdef MEMORY_TRACKING CALL MEM_TRACK('add_template_spec_int1','add',sizeoftemplate) #endif add%name = 'spec_int1' add%num_inputs = 5 ALLOCATE( add%input(add%num_inputs), stat=ierr ) IF (ierr /= 0) then write(lu_log,*) " add_template_spec_int1 : allocation failed" call peg_error('Bad allocate stat') end if #ifdef MEMORY_TRACKING CALL MEM_TRACK('add_template_spec_int1','add%input',add%num_inputs*sizeoftemplateinput) #endif ALLOCATE( add%input_type(add%num_inputs), stat=ierr ) IF (ierr /= 0) then write(lu_log,*) " add_template_spec_int1 : allocation failed" call peg_error('Bad allocate stat') end if #ifdef MEMORY_TRACKING CALL MEM_TRACK('add_template_spec_int1','add%input_type',add%num_inputs*sizeoftemplateinput_type) #endif add%input(1) = 'obound_inp' add%input_type(1) = 1 add%input(2) = 'spec_int1_inp' add%input_type(2) = 1 add%input(3) = 'hole' add%input_type(3) = 1 add%input(4) = 'bc' add%input_type(4) = 1 add%input(5) = 'iregion_inp' add%input_type(5) = 1 add%num_outputs = 1 ALLOCATE( add%output(add%num_outputs) , stat=ierr) if (ierr /= 0) then write(lu_log,*) " mod_spec_int1 : allocation failed" call peg_error('Bad allocate stat') end if #ifdef MEMORY_TRACKING CALL MEM_TRACK('add_template_spec_int1','add%output',add%num_outputs*sizeoftemplateoutput) #endif ALLOCATE( add%output_type(add%num_outputs), stat=ierr ) if (ierr /= 0) then write(lu_log,*) " mod_spec_int1 : allocation failed" call peg_error('Bad allocate stat') end if #ifdef MEMORY_TRACKING CALL MEM_TRACK('add_template_spec_int1','add%output_type',add%num_outputs*sizeoftemplateoutput_type) #endif add%output(1) = 'int1' add%output_type(1) = 1 CALL add_template( add ) deallocate( add%input, stat=ierr1 ) deallocate( add%input_type, stat=ierr2 ) deallocate( add%output, stat=ierr3 ) deallocate( add%output_type, stat=ierr4 ) deallocate( add, stat=ierr5 ) if ( ierr1.ne.0 .or. ierr2.ne.0 .or. ierr3.ne.0 .or. & ierr4.ne.0 .or. ierr5.ne.0 ) then call peg_error('bad deallocate stat : add_template_spec_int1') endif #ifdef MEMORY_TRACKING call MEM_TRACK('add_template_spec_int1','add%input', -1) call MEM_TRACK('add_template_spec_int1','add%input_type', -1) call MEM_TRACK('add_template_spec_int1','add%output', -1) call MEM_TRACK('add_template_spec_int1','add%output_type', -1) call MEM_TRACK('add_template_spec_int1','add', -1) #endif RETURN END SUBROUTINE add_template_spec_int1 !---------------------------------------------------------------------------------- SUBROUTINE add_process_spec_int1 USE mod_parameters USE mod_lunits USE mod_mesh USE mod_boundary USE mod_hcut USE mod_region USE mod_volume USE mod_mem_alloc IMPLICIT NONE TYPE (process), POINTER :: add __INTEGER :: m, b, nh, mh, h, ns CHARACTER, DIMENSION(:), ALLOCATABLE :: sizestring __INTEGER :: ierr, ierr1, ierr2, ierr3 DO m = 1,nmesh IF( phantom(m) ) CYCLE ALLOCATE( add, stat=ierr ) if (ierr /= 0) then write(lu_log,*) " mod_spec_int1 : allocation failed" call peg_error('Bad allocate stat') end if #ifdef MEMORY_TRACKING CALL MEM_TRACK('add_process_spec_int1','add', sizeofprocess) #endif add%name = 'spec_int1' add%primary_1 = name(m) add%primary_2 = blank_string add%num_secondary_1 = 0 ALLOCATE( add%secondary_1(add%num_secondary_1), stat=ierr ) if (ierr /= 0) then write(lu_log,*) " mod_spec_int1 : allocation failed" call peg_error('Bad allocate stat') end if #ifdef MEMORY_TRACKING CALL MEM_TRACK('add_process_spec_int1','add%secondary_1',add%num_secondary_1*sizeofprocesssecondary_1) #endif add%num_secondary_2 = 0 ALLOCATE( add%secondary_2(add%num_secondary_2), stat=ierr) if (ierr /= 0) then write(lu_log,*) " mod_spec_int1 : allocation failed" call peg_error('Bad allocate stat') end if #ifdef MEMORY_TRACKING CALL MEM_TRACK('add_process_spec_int1','add%secondary_2',add%num_secondary_2*sizeofprocesssecondary_2) #endif CALL add_process( add ) deallocate( add%secondary_1, stat=ierr1) deallocate( add%secondary_2, stat=ierr2) deallocate( add, stat=ierr3) if ( ierr1.ne.0 .or. ierr2.ne.0 .or. ierr3.ne.0 ) then call peg_error('bad deallocate stat : add_template_spec_int1') endif #ifdef MEMORY_TRACKING CALL MEM_TRACK('add_process_spec_int1','add%secondary_1',-1) CALL MEM_TRACK('add_process_spec_int1','add%secondary_2',-1) CALL MEM_TRACK('add_process_spec_int1','add',-1) #endif ENDDO CALL set_spec_int1_inp CALL set_obound_inp CALL set_iregion_inp RETURN END SUBROUTINE add_process_spec_int1 !---------------------------------------------------------------------------------- SUBROUTINE set_spec_int1_inp USE mod_parameters USE mod_mesh USE mod_outer USE mod_region USE mod_volume USE mod_spec_int1_inp USE mod_mem_alloc IMPLICIT NONE __REAL :: xincld_tmp(2), yincld_tmp(2), zincld_tmp(2) __INTEGER :: jincld_tmp(2), kincld_tmp(2), lincld_tmp(2) __REAL :: xtmp(2), ytmp(2), ztmp(2) __INTEGER :: jtmp(2), ktmp(2), ltmp(2) __INTEGER :: ifringe_tmp, ihfringe_tmp, iofringe_tmp LOGICAL :: incld_tmp, outer_bc_tmp __INTEGER :: num_vol_tmp, m, ns, nr, nv, vl, ierr LOGICAL :: exist_spec_int1_inp, write_spec_int1_inp CHARACTER (LEN=nchar2) :: file_spec_int1_inp DO m = 1, nmesh IF( phantom(m) ) CYCLE write_spec_int1_inp = .false. CALL set_file_name_spec_int1_inp( name(m), file_spec_int1_inp ) INQUIRE( FILE=file_spec_int1_inp, EXIST=exist_spec_int1_inp ) IF( exist_spec_int1_inp ) THEN CALL load_spec_int1_inp( name(m),incld_tmp, & xincld_tmp, yincld_tmp, zincld_tmp, & jincld_tmp, kincld_tmp, lincld_tmp, & ifringe_tmp, ihfringe_tmp, iofringe_tmp, & outer_bc_tmp ) IF( incld_tmp .AND. .NOT.incld(m) .OR. & .NOT.incld_tmp .AND. incld(m) ) write_spec_int1_inp = .true. IF( xincld_tmp(1) .NE. xincld(1,m) .OR. & xincld_tmp(2) .NE. xincld(2,m) .OR. & yincld_tmp(1) .NE. yincld(1,m) .OR. & yincld_tmp(2) .NE. yincld(2,m) .OR. & zincld_tmp(1) .NE. zincld(1,m) .OR. & zincld_tmp(2) .NE. zincld(2,m) .OR. & jincld_tmp(1) .NE. jincld(1,m) .OR. & jincld_tmp(2) .NE. jincld(2,m) .OR. & kincld_tmp(1) .NE. kincld(1,m) .OR. & kincld_tmp(2) .NE. kincld(2,m) .OR. & lincld_tmp(1) .NE. lincld(1,m) .OR. & lincld_tmp(2) .NE. lincld(2,m) ) write_spec_int1_inp = .true. IF( ifringe_tmp .NE. ifringe(m) .OR. & ihfringe_tmp .NE. ihfringe(m) .OR. & iofringe_tmp .NE. iofringe(m) ) write_spec_int1_inp = .true. IF( outer_bc_tmp .AND. .NOT.outer_bc(m) .OR. & .NOT.outer_bc_tmp .AND. outer_bc(m) ) write_spec_int1_inp = .true. ELSE write_spec_int1_inp = .true. ENDIF IF( write_spec_int1_inp ) THEN ! wed 6/15/99 the following call causes some compilers grief ! CALL store_spec_int1_inp( name(m),incld(m), & ! xincld(1,m), yincld(1,m), zincld(1,m), & ! jincld(1,m), kincld(1,m), lincld(1,m), & ! ifringe(m), ihfringe(m), iofringe(m), & ! outer_bc(m) ) ! use temp storage xtmp(1) = xincld(1,m) xtmp(2) = xincld(2,m) ytmp(1) = yincld(1,m) ytmp(2) = yincld(2,m) ztmp(1) = zincld(1,m) ztmp(2) = zincld(2,m) jtmp(1) = jincld(1,m) jtmp(2) = jincld(2,m) ktmp(1) = kincld(1,m) ktmp(2) = kincld(2,m) ltmp(1) = lincld(1,m) ltmp(2) = lincld(2,m) CALL store_spec_int1_inp( name(m),incld(m), & xtmp,ytmp,ztmp, & jtmp,ktmp,ltmp, & ifringe(m), ihfringe(m), iofringe(m), & outer_bc(m) ) ENDIF ENDDO RETURN END SUBROUTINE set_spec_int1_inp !---------------------------------------------------------------------------------- SUBROUTINE set_obound_inp USE mod_parameters USE mod_lunits USE mod_mesh USE mod_boundary USE mod_surface USE mod_obound_inp USE mod_mem_alloc IMPLICIT NONE __INTEGER, DIMENSION(:,:), ALLOCATABLE :: jrange_tmp __INTEGER, DIMENSION(:,:), ALLOCATABLE :: krange_tmp __INTEGER, DIMENSION(:,:), ALLOCATABLE :: lrange_tmp __INTEGER :: num_surf_tmp, m, ns, n, nb, ierr LOGICAL :: exist_obound_inp, write_obound_inp CHARACTER (LEN=nchar2) :: file_obound_inp ALLOCATE( jrange_tmp(2,nsurf), STAT=ierr) IF( ierr /= 0 ) then WRITE(lu_log,*) " jrange_tmp: allocation failed" call peg_error('Bad allocate stat') endif #ifdef MEMORY_TRACKING CALL MEM_TRACK('set_obound_inp','jrange_tmp',2*nsurf*sizeofint) #endif ALLOCATE( krange_tmp(2,nsurf), STAT=ierr) IF( ierr /= 0 ) then WRITE(lu_log,*) " krange_tmp: allocation failed" call peg_error('Bad allocate stat') endif #ifdef MEMORY_TRACKING CALL MEM_TRACK('set_obound_inp','krange_tmp',2*nsurf*sizeofint) #endif ALLOCATE( lrange_tmp(2,nsurf), STAT=ierr) IF( ierr /= 0 ) then WRITE(lu_log,*) " lrange_tmp: allocation failed" call peg_error('Bad allocate stat') endif #ifdef MEMORY_TRACKING CALL MEM_TRACK('set_obound_inp','lrange_tmp',2*nsurf*sizeofint) #endif jrange_tmp = 0 krange_tmp = 0 lrange_tmp = 0 DO m = 1, nmesh IF( phantom(m) ) CYCLE write_obound_inp = .false. CALL set_file_name_obound_inp( name(m), file_obound_inp ) INQUIRE( FILE=file_obound_inp, EXIST=exist_obound_inp ) IF( exist_obound_inp ) THEN CALL load_obound_inp( name(m), & num_surf_tmp, & jrange_tmp,krange_tmp,lrange_tmp ) n = 0 nb = 0 IF( nsurf .EQ. 0 .AND. num_surf_tmp .GT. 0 ) THEN write_obound_inp = .true. ELSE DO ns = 1,nsurf nb = boundary_no(ispartbs(ns)) IF( name(m) .EQ. ispartmb(nb) .AND. btype(nb).EQ.'OUTER' ) THEN n = n + 1 IF( n.GT.num_surf_tmp ) THEN write_obound_inp = .true. EXIT ELSE IF( jrange(1,ns) .NE. jrange_tmp(1,n) .OR. & jrange(2,ns) .NE. jrange_tmp(2,n) .OR. & krange(1,ns) .NE. krange_tmp(1,n) .OR. & krange(2,ns) .NE. krange_tmp(2,n) .OR. & lrange(1,ns) .NE. lrange_tmp(1,n) .OR. & lrange(2,ns) .NE. lrange_tmp(2,n) ) write_obound_inp = .true. ENDIF ENDIF ENDDO ENDIF ELSE write_obound_inp = .true. ENDIF IF( write_obound_inp ) THEN n = 0 DO nb = 1,nboun IF( name(m) .EQ. ispartmb(nb) .AND. btype(nb) .EQ. 'OUTER' ) THEN DO ns = 1,nsurf IF( ispartmb(nb) .EQ. ispartbs(ns) ) THEN n = n + 1 jrange_tmp(1,n) = jrange(1,ns) jrange_tmp(2,n) = jrange(2,ns) krange_tmp(1,n) = krange(1,ns) krange_tmp(2,n) = krange(2,ns) lrange_tmp(1,n) = lrange(1,ns) lrange_tmp(2,n) = lrange(2,ns) ENDIF ENDDO ENDIF ENDDO num_surf_tmp = n CALL store_obound_inp( name(m), & num_surf_tmp, & jrange_tmp,krange_tmp,lrange_tmp ) ENDIF ENDDO DEALLOCATE( jrange_tmp, STAT=IERR ) IF( IERR /= 0 ) call peg_error('Bad DEALLOCATE STAT for jrange_tmp') #ifdef MEMORY_TRACKING CALL MEM_TRACK('set_obound_inp','jrange_tmp',-1) #endif DEALLOCATE( krange_tmp, STAT=IERR ) IF( IERR /= 0 ) call peg_error('Bad DEALLOCATE STAT for krange_tmp') #ifdef MEMORY_TRACKING CALL MEM_TRACK('set_obound_inp','krange_tmp',-1) #endif DEALLOCATE( lrange_tmp, STAT=IERR ) IF( IERR /= 0 ) call peg_error('Bad DEALLOCATE STAT for lrange_tmp') #ifdef MEMORY_TRACKING CALL MEM_TRACK('set_obound_inp','lrange_tmp',-1) #endif RETURN END SUBROUTINE set_obound_inp !***************************************************************** subroutine set_iregion_inp use mod_parameters use mod_lunits use mod_mesh use mod_region use mod_volume use mod_iregion_inp use mod_mem_alloc implicit none __INTEGER, dimension(:,:), allocatable :: jrangev_tmp __INTEGER, dimension(:,:), allocatable :: krangev_tmp __INTEGER, dimension(:,:), allocatable :: lrangev_tmp __INTEGER :: num_vol_tmp, m, ns, nr, nv, vl, ierr logical :: exist_iregion_inp, write_iregion_inp character (len=nchar2) :: file_iregion_inp allocate( jrangev_tmp(2,nvol), stat=ierr) if( ierr /= 0 ) then write(lu_log,*) " jrangev_tmp: allocation failed" call peg_error('bad allocate stat') endif #ifdef MEMORY_TRACKING call mem_track('set_iregion_inp','jrangev_tmp',2*nvol*sizeofint) #endif allocate( krangev_tmp(2,nvol), stat=ierr) if( ierr /= 0 ) then write(lu_log,*) " krangev_tmp: allocation failed" call peg_error('bad allocate stat') endif #ifdef MEMORY_TRACKING call mem_track('set_iregion_inp','krangev_tmp',2*nvol*sizeofint) #endif allocate( lrangev_tmp(2,nvol), stat=ierr) if( ierr /= 0 ) then write(lu_log,*) " lrangev_tmp: allocation failed" call peg_error('bad allocate stat') endif #ifdef MEMORY_TRACKING call mem_track('set_iregion_inp','lrangev_tmp',2*nvol*sizeofint) #endif jrangev_tmp = 0 krangev_tmp = 0 lrangev_tmp = 0 do m = 1, nmesh if( phantom(m) ) cycle write_iregion_inp = .false. call set_file_name_iregion_inp( name(m), file_iregion_inp ) inquire( file=file_iregion_inp, exist=exist_iregion_inp ) if( exist_iregion_inp ) then call load_iregion_inp( name(m), & num_vol_tmp, & jrangev_tmp,krangev_tmp,lrangev_tmp ) vl = 0 if( nvol .eq. 0 .and. num_vol_tmp .gt. 0 ) then write_iregion_inp = .true. else do nv = 1,nvol nr = region_no(ispartr(nv)) if( name(m) .eq. ispartmr(nr) .and. rtype(nr).eq.'INTR' ) then vl = vl + 1 if( vl.gt. num_vol_tmp ) then write_iregion_inp = .true. exit else if( jrangev(1,nv) .ne. jrangev_tmp(1,vl) .or. & jrangev(2,nv) .ne. jrangev_tmp(2,vl) .or. & krangev(1,nv) .ne. krangev_tmp(1,vl) .or. & krangev(2,nv) .ne. krangev_tmp(2,vl) .or. & lrangev(1,nv) .ne. lrangev_tmp(1,vl) .or. & lrangev(2,nv) .ne. lrangev_tmp(2,vl) ) & write_iregion_inp = .true. endif endif enddo endif else write_iregion_inp = .true. endif if( write_iregion_inp ) then vl = 0 do nv = 1,nvol nr = region_no(ispartr(nv)) if( name(m) .eq. ispartmr(nr) .and. rtype(nr).eq.'INTR' ) then vl = vl + 1 jrangev_tmp(1,vl) = jrangev(1,nv) jrangev_tmp(2,vl) = jrangev(2,nv) krangev_tmp(1,vl) = krangev(1,nv) krangev_tmp(2,vl) = krangev(2,nv) lrangev_tmp(1,vl) = lrangev(1,nv) lrangev_tmp(2,vl) = lrangev(2,nv) endif enddo num_vol_tmp = vl call store_iregion_inp( name(m), & num_vol_tmp, & jrangev_tmp,krangev_tmp,lrangev_tmp ) endif enddo deallocate( jrangev_tmp, stat=ierr ) if( ierr /= 0 ) call peg_error('bad deallocate stat for jrangev_tmp') #ifdef MEMORY_TRACKING call mem_track('set_iregion_inp','jrangev_tmp',-1) #endif deallocate( krangev_tmp, stat=ierr ) if( ierr /= 0 ) call peg_error('bad deallocate stat for krangev_tmp') #ifdef MEMORY_TRACKING call mem_track('set_iregion_inp','krangev_tmp',-1) #endif deallocate( lrangev_tmp, stat=ierr ) if( ierr /= 0 ) call peg_error('bad deallocate stat for lrangev_tmp') #ifdef MEMORY_TRACKING call mem_track('set_iregion_inp','lrangev_tmp',-1) #endif return end subroutine set_iregion_inp !------------------------------------------------------------------------------- SUBROUTINE execute_spec_int1( proc ) ! ! This routine determines which points need interpolation stencils ! for a single zone. It builds an iblank array which is initialized ! to 1. Then the hole points get set to iblank=0. It identifies ! all fringe and outer boundary points and marks these with ! iblank=2 at first-layer fringe points, and iblank=3 at second-layer ! fringe points. It then excludes some fringe points by setting ! iblank=1 for points outside the INCLUDE ranges, and for any VOLUME ! points of region type=INTR. Finally it builds a list of the ! indices of these points and writes it to the final output file. ! use mod_mesh use mod_outer use mod_xvals use mod_lunits use mod_log_file use mod_ptr_hole use mod_hole use mod_ptr_int1 use mod_int1 use mod_mem_alloc implicit none type (process), pointer :: proc __INTEGER :: m, num_ptsf1, num_ptsf2, ierr, j, k, l, i1, i2 __INTEGER :: num_ihole, nh __INTEGER, dimension(:,:,:), allocatable :: iblank m = mesh_no(proc%primary_1) allocate( iblank(mjmax(m),mkmax(m),mlmax(m)), STAT=ierr) if( ierr /= 0 ) then write(lu_log,*) " iblank: allocation failed" call peg_error('Bad allocate stat') endif #ifdef MEMORY_TRACKING call mem_track('execute_spec_int1','iblank',mjmax(m)*mkmax(m)*mlmax(m)*sizeofint) #endif iblank = 1 call load_hole( proc%primary_1, num_ihole, ihole ) do nh = 1,num_ihole call itojkl( ihole(nh),j,k,l,m ) iblank(j,k,l) = 0 enddo if( ihfringe(m).eq.1 ) then ! Find single fringes around the holes call fringe1( iblank,mjmax(m),mkmax(m),mlmax(m) ) else if( ihfringe(m).eq.2 ) then ! Find double fringes around the holes call fringe2( iblank,mjmax(m),mkmax(m),mlmax(m) ) endif ! Find outer-boundary fringes if( outer_bc(m) ) then call find_outer_bc( iblank, mjmax(m), mkmax(m), mlmax(m), m ) endif call find_outer( iblank, mjmax(m), mkmax(m), mlmax(m), m ) call exclude_pts( iblank, mjmax(m), mkmax(m), mlmax(m), m ) ! ! Count number of first-fringe points ! num_ptsf1 = 0 do l = 1,mlmax(m) do k = 1,mkmax(m) do j = 1,mjmax(m) if( iblank(j,k,l) .eq. 2 ) num_ptsf1 = num_ptsf1 + 1 enddo enddo enddo ! ! Count number of second-fringe points ! num_ptsf2 = 0 do l = 1,mlmax(m) do k = 1,mkmax(m) do j = 1,mjmax(m) if( iblank(j,k,l) .eq. 3 ) num_ptsf2 = num_ptsf2 + 1 enddo enddo enddo call alloc_int1( proc%primary_1, num_ptsf1, iint1f1, num_ptsf2, iint1f2 ) ! ! Build lists of fringe points ! i1 = 0 i2 = 0 do l = 1,mlmax(m) do k = 1,mkmax(m) do j = 1,mjmax(m) if( iblank(j,k,l) .eq. 2 ) then i1 = i1 + 1 iint1f1(i1) = jkltoi(j,k,l,m) elseif( iblank(j,k,l) .eq. 3 ) then i2 = i2 + 1 iint1f2(i2) = jkltoi(j,k,l,m) endif enddo enddo enddo write(lu_log,1) num_ptsf1, proc%primary_1 write(lu_log,2) num_ptsf2, proc%primary_1 1 format(' FOUND:',I10,' first-fringe points requiring interpolation,'/, & ' for: ',A40,/ ) 2 format(' FOUND:',I10,' second-fringe points requiring interpolation,'/, & ' for: ',A40,/ ) call store_int1 ( proc%primary_1 ) deallocate( iblank, stat=ierr ) if( ierr /= 0 ) call peg_error('Bad DEALLOCATE STAT for iblank') #ifdef MEMORY_TRACKING call mem_track('execute_spec_int1','iblank',-1) #endif return END SUBROUTINE execute_spec_int1 END MODULE mod_spec_int1