e4d_run.F90       coverage:  100.00 %func     86.99 %block


     1) module e4d_run
     2) 
     3)   use vars
     4)   integer :: pf_com
     5)   logical :: first_sol = .true.
     6)   logical :: sim_e4d = .false.
     7)   integer :: mcomm
     8)   !real*8 :: pf_time
     9) contains
    10)   
    11)   !_____________________________________________________________________
    12)   subroutine run_e4d
    13)   
    14)     implicit none
    15)     logical :: first_flag = .true.
    16)     
    17)     if (my_rank>0) then
    18)        call slave_run
    19)        call cleanup
    20)        return
    21)     end if
    22)    
    23)     if (.not. allocated(pf_porosity)) allocate(pf_porosity(pflotran_vec_size))
    24)     if (.not. allocated(pf_tracer)) allocate(pf_tracer(pflotran_vec_size))
    25)     if (.not. allocated(pf_saturation)) &
    26)       allocate(pf_saturation(pflotran_vec_size))
    27)     if (.not. allocated(pf_saturation_0)) &
    28)       allocate(pf_saturation_0(pflotran_vec_size))
    29)     ! if energy is being modeled, pflotran_temperature_vec_mpi will be non-zero
    30)     if (pflotran_temperature_vec_mpi /= 0 .and. &
    31)         .not. allocated(pf_temperature)) &
    32)       allocate(pf_temperature(pflotran_vec_size))
    33)     if (.not. allocated(sigma)) allocate(sigma(nelem))
    34)    
    35) 
    36)     call get_mcomm
    37)     call cpu_time(Cbeg)
    38)     call get_pf_porosity       !!get the pflotran porosity
    39)     do while (mcomm==1)
    40) 
    41)        call get_pf_time      !!get the pflotran solution time
    42)        call get_pf_sol       !!get the pflotran solution
    43)       
    44)        call elog(36,mcomm,mcomm)
    45) 
    46)        call check_e4d_sim    !!see if we should do an e4d sim for this time
    47)        
    48)        if (sim_e4d) then
    49) 
    50)           
    51) 
    52)           if (first_flag) then
    53)              pf_saturation_0 = pf_saturation
    54)              !call compute_FF
    55)              first_flag = .false.
    56)           end if
    57)  
    58)           call map_pf_e4d       !!map/transform the solution to the E4D mesh
    59)           call send_sigma       !!send the transformed solution to the slaves           
    60)           call send_command(3)  !!instruct slaves to build A matrix
    61)           call send_command(5)  !!instruct slaves to build KSP solver
    62)           call send_command(6)  !!instruct slaves to solve  
    63)          call get_dpred        !!assemble the simulated data
    64)           call cpu_time(Cbeg)
    65)        end if
    66)      
    67)        call get_mcomm
    68)       
    69)     end do
    70) 
    71)     call send_command(0)  !!instruct slaves to exit
    72)     call cleanup
    73)     return
    74) 
    75)      
    76)   end subroutine run_e4d
    77)   !____________________________________________________________________
    78) 
    79)   !____________________________________________________________________
    80)   subroutine check_e4d_sim
    81)     implicit none
    82)     integer :: tmp,i,ios,j,junk,a,b,m,n
    83)    
    84) 
    85)     open(13,file=trim(log_file),status='old',action='write',position='append')
    86)     write(13,*) "Min/Max Tracer Value: ",minval(pf_tracer),maxval(pf_tracer)
    87)     close(13)
    88)     sim_e4d = .false.
    89)     
    90)     open(10,file=trim(list_file),status='old',action='read')
    91)     read(10,*) tmp
    92)     do i=1,ntime
    93)        read(10,*) e4d_time,csrv_file,ccond_file
    94)        if (e4d_time .eq. pf_time) then
    95)           call elog(35,i,tmp)
    96)           close(10)
    97)           
    98)           open(10,file=trim(ccond_file),status='old',action='read')
    99)           read(10,*,IOSTAT=ios) nsig
   100)           if (ios .ne. 0)       call elog(31,ios,tmp)
   101)           if (nsig .ne. nelem)  call elog(32,nsig,nelem)
   102)           if (.not.allocated(sigma)) allocate(sigma(nelem))
   103)           do j=1,nelem
   104)              read(10,*) sigma(j)
   105)           end do
   106)           close(10)
   107) 
   108)           open(10,file=trim(csrv_file),status='old',action='read')
   109)           read(10,*,IOSTAT=ios) tmp
   110)           call elog(27,ios,tmp)
   111)           do j=1,tmp
   112)              read(10,*) junk
   113)           end do
   114)           read(10,*,IOSTAT=ios) tmp
   115)           call elog(29,ios,tmp)
   116)           if (.not. allocated(dobs)) allocate(dobs(nm))
   117)           if (.not. allocated(sd)) allocate(sd(nm))
   118)           do j=1,nm
   119)              read(10,*,IOSTAT=ios) tmp,a,b,m,n,dobs(j),sd(j)
   120)           end do 
   121)           close(10)
   122)           sim_e4d = .true.
   123)           return
   124)        end if
   125)     end do
   126) 
   127)     close(10)
   128)     open(13,file=trim(log_file),status='old',action='write',position='append')
   129)     write(13,*) "No E4D survey found for pflotran time: ",pf_time
   130)     close(13)
   131)   end subroutine check_e4d_sim
   132)   !____________________________________________________________________
   133) 
   134)   !____________________________________________________________________
   135)   subroutine get_mcomm
   136)     implicit none
   137) !geh    call MPI_BCAST(mcomm,1,MPI_INTEGER,0,PFE4D_COMM,ierr)
   138)     call MPI_BCAST(mcomm,1,MPI_INTEGER,0,PFE4D_MASTER_COMM,ierr)
   139)   end subroutine get_mcomm
   140)   !____________________________________________________________________
   141) 
   142)   !____________________________________________________________________
   143)   subroutine get_pf_time
   144)     implicit none
   145)     call MPI_BCAST(pf_time,1,MPI_DOUBLE_PRECISION,0,PFE4D_MASTER_COMM, &
   146)                    ierr)
   147)    
   148)   end subroutine get_pf_time
   149)   !____________________________________________________________________
   150) 
   151)   !____________________________________________________________________
   152)   subroutine get_pf_porosity
   153)     implicit none
   154) #include "petsc/finclude/petscvec.h"
   155) #include "petsc/finclude/petscvec.h90"
   156)     integer ::  status(MPI_STATUS_SIZE)
   157)     PetscReal, pointer :: vec_ptr(:)
   158) 
   159)  
   160)     ! porosity
   161)     ! we actually hijack the tracer vec to transfer porosity
   162)     call VecScatterBegin(pflotran_scatter,pflotran_tracer_vec_mpi, &
   163)                          pflotran_tracer_vec_seq, &
   164)                          INSERT_VALUES,SCATTER_FORWARD,perr);CHKERRQ(perr)
   165)     call VecScatterEnd(pflotran_scatter,pflotran_tracer_vec_mpi, &
   166)                        pflotran_tracer_vec_seq, &
   167)                        INSERT_VALUES,SCATTER_FORWARD,perr);CHKERRQ(perr)
   168)     call VecGetArrayF90(pflotran_tracer_vec_seq,vec_ptr,perr);CHKERRQ(perr)
   169)     pf_porosity = real(vec_ptr)
   170) 
   171)     call VecRestoreArrayF90(pflotran_tracer_vec_seq,vec_ptr, &
   172)                             perr);CHKERRQ(perr)
   173) 
   174)   end subroutine get_pf_porosity
   175)   !____________________________________________________________________
   176) 
   177)   !____________________________________________________________________
   178)   subroutine get_pf_sol
   179)     implicit none
   180) #include "petsc/finclude/petscvec.h"
   181) #include "petsc/finclude/petscvec.h90"
   182)     integer ::  status(MPI_STATUS_SIZE)
   183)     PetscReal, pointer :: vec_ptr(:)
   184) 
   185)  
   186)     ! tracer
   187)     call VecScatterBegin(pflotran_scatter,pflotran_tracer_vec_mpi, &
   188)                          pflotran_tracer_vec_seq, &
   189)                          INSERT_VALUES,SCATTER_FORWARD,perr);CHKERRQ(perr)
   190)     call VecScatterEnd(pflotran_scatter,pflotran_tracer_vec_mpi, &
   191)                        pflotran_tracer_vec_seq, &
   192)                        INSERT_VALUES,SCATTER_FORWARD,perr);CHKERRQ(perr)
   193)     call VecGetArrayF90(pflotran_tracer_vec_seq,vec_ptr,perr);CHKERRQ(perr)
   194)     pf_tracer = real(vec_ptr)
   195) 
   196)     call VecRestoreArrayF90(pflotran_tracer_vec_seq,vec_ptr, &
   197)                             perr);CHKERRQ(perr)
   198) 
   199)     ! saturation                
   200)     call VecScatterBegin(pflotran_scatter,pflotran_saturation_vec_mpi, &
   201)                          pflotran_saturation_vec_seq, &
   202)                          INSERT_VALUES,SCATTER_FORWARD,perr);CHKERRQ(perr)
   203)     call VecScatterEnd(pflotran_scatter,pflotran_saturation_vec_mpi, &
   204)                        pflotran_saturation_vec_seq, &
   205)                        INSERT_VALUES,SCATTER_FORWARD,perr);CHKERRQ(perr)
   206)     call VecGetArrayF90(pflotran_saturation_vec_seq,vec_ptr,perr);CHKERRQ(perr)
   207)     pf_saturation = real(vec_ptr)
   208)     call VecRestoreArrayF90(pflotran_saturation_vec_seq,vec_ptr, &
   209)                             perr);CHKERRQ(perr)
   210) 
   211)     ! temperature  (only modeled when energy is simulated)
   212)     if (pflotran_temperature_vec_mpi /= 0) then
   213)       call VecScatterBegin(pflotran_scatter,pflotran_temperature_vec_mpi, &
   214)                            pflotran_temperature_vec_seq, &
   215)                            INSERT_VALUES,SCATTER_FORWARD,perr);CHKERRQ(perr)
   216)       call VecScatterEnd(pflotran_scatter,pflotran_temperature_vec_mpi, &
   217)                          pflotran_temperature_vec_seq, &
   218)                          INSERT_VALUES,SCATTER_FORWARD,perr);CHKERRQ(perr)
   219)       call VecGetArrayF90(pflotran_temperature_vec_seq,vec_ptr, &
   220)                           perr);CHKERRQ(perr)
   221)       pf_temperature = real(vec_ptr)
   222)       call VecRestoreArrayF90(pflotran_temperature_vec_seq,vec_ptr, &
   223)                             perr);CHKERRQ(perr)
   224)     endif
   225)  
   226)   end subroutine get_pf_sol
   227)   !____________________________________________________________________
   228) 
   229)   !____________________________________________________________________
   230)   subroutine map_pf_e4d
   231) 
   232)     implicit none
   233)     integer :: i,cnt 
   234)     character*40 :: filename, word
   235)     real :: K,St,C,parSat,delSigb,Sigf,delSigb_min
   236)     real, parameter :: m=2.0      !!m is the saturation exponent ... assumed to be 2    
   237)     !real, dimension(nelem) :: pftrac
   238)     !pftrac=0
   239)     !sigma=0.001 !sigma_base
   240)     !do i=1,nmap
   241)     !   sigma(map_inds(i,1)) = sigma(map_inds(i,1))+map(i)*pf_tracer(map_inds(i,2))
   242)     !   pftrac(map_inds(i,1))=  pftrac(map_inds(i,1)) +map(i)*pf_tracer(map_inds(i,2))
   243)     !end do
   244)  
   245)     do i=1,nmap 
   246) 
   247)        Sigf = gw_sig + (sw_sig-gw_sig)*pf_tracer(map_inds(i,2))           !pore water conductivity
   248)        delSigb = (Sigf*pf_saturation(map_inds(i,2))**(m))/FF-sigma(map_inds(i,1)) 
   249)        sigma(map_inds(i,1)) = sigma(map_inds(i,1)) + map(i)*delSigb
   250) 
   251)     end do
   252)     
   253)     do i=1,nelem
   254)        if (sigma(i)<1e-6) sigma(i)=1e-6
   255)     end do
   256)  
   257)     !write(*,*) pf_time
   258)     write(word,'(i15.15)') int(pf_time)
   259)     filename = 'sigma_' // &
   260)                trim(adjustl(pflotran_group_prefix)) // &
   261)                '_' // &
   262)                trim(adjustl(word)) // &
   263)                '.txt' 
   264)     !write(*,*) filename
   265)     open(unit=86,file=trim(filename),status='replace',action='write')
   266)     write(86,*) nelem, "1", minval(sigma),maxval(sigma)
   267)     do i = 1, nelem
   268)        write(86,*) sigma(i) 
   269)     enddo
   270)     close(86)
   271) 
   272)   end subroutine map_pf_e4d
   273)   !____________________________________________________________________
   274) 
   275)   !____________________________________________________________________
   276)   !subroutine compute_FF
   277)   !  implicit none
   278)   !  integer :: i
   279)   !  real, parameter :: m = 2
   280)   !  allocate(ffac(nelem))
   281)   !  ffac = 0
   282)   !  do i=1,nmap
   283)   !      ffac(map_inds(i,1)) = ffac(map_inds(i,1)) + map(i)*(gw_sig*pf_saturation_0(map_inds(i,2))**(m))/sigma(map_inds(i,1))
   284)   !  end do
   285)   !  open(13,file='FF_Derived.txt',status='replace',action='write')
   286)   !  write(13,*) nelem
   287)   !  do i=1,nelem
   288)   !     write(13,*) ffac(i)
   289)   !  end do
   290)   !  close(13)
   291)   !end subroutine compute_FF
   292)   !____________________________________________________________________
   293) 
   294)   !____________________________________________________________________
   295)   subroutine send_sigma
   296)     implicit none
   297)     
   298)     call send_command(4)
   299)     call MPI_BCAST(sigma, nelem,MPI_REAL,0,E4D_COMM,ierr)
   300)     
   301)   end subroutine send_sigma
   302)   !____________________________________________________________________
   303) 
   304)   !____________________________________________________________________
   305)   subroutine get_dpred
   306)     implicit none
   307)     integer :: opt
   308)     integer :: i,j
   309)     integer :: nadd
   310)     integer :: nbuff
   311)     integer, dimension(nm*2) :: ibuff
   312)     real, dimension(nm) :: rbuff
   313)     integer ::  status(MPI_STATUS_SIZE)
   314)     character*40 :: filename, word 
   315) 
   316) 
   317)     !instruct slave to assemble and send the prediceted data
   318)     call send_command(8)
   319)     
   320)     !allocate dpred if not already done and zero
   321)     if (.not. allocated(dpred)) then
   322)        allocate(dpred(nm))
   323)     end if
   324)     dpred = 0
   325)     rbuff = 0
   326)     ibuff = 1
   327)     do i=1,n_rank-1 
   328)        call MPI_RECV(nbuff,1,MPI_INTEGER,i,0,E4D_COMM,status,ierr)
   329)        call MPI_RECV(ibuff(1:nbuff),nbuff,MPI_INTEGER,i,0,E4D_COMM,status,ierr)
   330)        call MPI_RECV(rbuff(1:nbuff),nbuff,MPI_REAL,i,0,E4D_COMM,status,ierr)
   331)        
   332)        do j=1,nbuff
   333)           dpred(ibuff(j))=dpred(ibuff(j))+rbuff(j)
   334)        end do
   335)        
   336)     end do
   337) 
   338)       
   339)     
   340)     write(word,'(i15.15)') int(pf_time)
   341)     filename = 'e4d_' // &
   342)                trim(adjustl(pflotran_group_prefix)) // &
   343)                '_' // &
   344)                trim(adjustl(word)) // &
   345)                '.dpd' 
   346)     write(*,*) filename
   347)     open(unit=86,file=trim(filename),status='replace',action='write')
   348)     write(86,*) nm
   349)     do i = 1, nm
   350)        write(86,'(I6,4I6,4F15.8)') i,s_conf(i,1:4),dpred(i),dobs(i),dpred(i)/sd(i),dobs(i)/sd(i)
   351)     enddo
   352)     close(86)
   353)     
   354)     !!output the predicted data to file
   355)     !call output_dpred
   356)   end subroutine get_dpred
   357)   !____________________________________________________________________
   358)   
   359) 
   360)   !______________________________________________________________
   361)   subroutine send_command(com)
   362)     !!Send a general command to the slaves
   363)     integer :: com
   364)     call MPI_BCAST(com,1,MPI_INTEGER,0,E4D_COMM,ierr)
   365)   end subroutine send_command
   366)   !________________________________________________________________
   367)   
   368) 
   369) 
   370) 
   371)   !___________SLAVE SUBROUTINES________________________________________
   372) 
   373)   !____________________________________________________________________
   374)   subroutine slave_run
   375)     implicit none
   376)     integer :: command
   377)     
   378) 100 continue
   379)     !Recieve a command from master
   380)     call MPI_BCAST(command,1,MPI_INTEGER,0,E4D_COMM,ierr)
   381)     
   382)     !return to main
   383)     if (command == 0) then
   384)        return
   385) 
   386)     else if (command == 3) then     
   387)        call build_A
   388)        goto 100
   389)          
   390)     else if (command == 4) then
   391)        call receive_sigma
   392)        goto 100
   393) 
   394)     else if (command == 5) then
   395)        call build_ksp
   396)        goto 100
   397) 
   398)     else if (command == 6) then
   399)        call forward_run
   400)        goto 100
   401)        
   402)     else if (command == 8) then
   403)        call send_dpred 
   404)        goto 100
   405)        
   406)     else 
   407)        goto 100
   408) 
   409)     end if
   410) 
   411)   end subroutine slave_run
   412)   !____________________________________________________________________
   413)   !__________________________________________________________________
   414)   subroutine receive_sigma
   415) 
   416)     implicit none
   417)     character(len=32) :: filename, word
   418)     integer :: i
   419)     integer, save :: num_calls = 0
   420)     call MPI_BCAST(sigma, nelem,MPI_REAL,0,E4D_COMM,ierr)   
   421) !geh
   422) 
   423) !write(filename,*) num_calls
   424) !write(word,*) my_rank
   425) !filename = 'sigma_' // trim(adjustl(word)) // '_' // &
   426) !           trim(adjustl(filename)) // '.txt'
   427) !open(unit=86,file=filename,status='replace',action='write')
   428) !do i = 1, nelem
   429) !  write(86,*) sigma(i)
   430) !enddo
   431) !close(86)
   432) 
   433) !num_calls = num_calls + 1
   434) !    print *, 'sigma received by slave', sigma(16)
   435)   end subroutine receive_sigma
   436)   !__________________________________________________________________
   437) 
   438)   !__________________________________________________________________
   439)   subroutine build_A
   440)     implicit none
   441)     
   442)     integer, dimension(nnodes) :: ncolss
   443)     integer, dimension(50) :: colss
   444)     
   445)     integer :: i,lrnl,lrnu,row,col,rbv,cbv,j,ifn
   446)     logical :: ilow,iup
   447)     
   448)     integer :: rw   
   449)     integer :: ncls 
   450)     integer :: cls(50) 
   451)     
   452)     
   453)     !zero A
   454)     call MatZeroEntries(A,perr);CHKERRQ(perr)
   455)     
   456)     do i=1,10*nelem
   457)        row=rows(A_map(i))
   458)        col=cols(A_map(i))
   459)        rbv=nbounds(row)
   460)        cbv=nbounds(col)
   461)        
   462)        !lower triangle
   463)        if ((rbv>=2 .and. rbv<=6) .or. (cbv>=2 .and. cbv<=6)) then
   464)           !one or both nodes are on a boundary so set to zero for bc's
   465)           val(1) = 1e-30
   466)        else
   467)           
   468)           val(1) = sigma(S_map(i))*delA(i)
   469)     
   470)        end if
   471)        
   472)        prn(1) = row-1
   473)        pcn(1) = col-1
   474)        
   475)        call MatSetValues(A,1,prn,1,pcn,val,ADD_VALUES,perr);CHKERRQ(perr)
   476)        !upper triangle
   477)        if (row .ne. col) then
   478)           call MatSetValues(A,1,pcn,1,prn,val,ADD_VALUES,perr);CHKERRQ(perr)
   479)        end if
   480)        
   481)     end do
   482)      
   483)     call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,perr);CHKERRQ(perr)
   484)     call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,perr);CHKERRQ(perr)
   485)     
   486)     
   487)     
   488)   end subroutine build_A
   489)   !__________________________________________________________________
   490) 
   491)   !__________________________________________________________________
   492)   subroutine build_ksp
   493)     implicit none
   494) #include "petsc/finclude/petscksp.h"
   495) #include "petsc/finclude/petscksp.h90"
   496)     real*8 :: rtol = 1e-6
   497)     real*8 :: atol = 1e-35
   498)     real*8 :: dtol = 500
   499)     integer :: maxints = 10000
   500)     !KSPSetTolerances(KSP ksp,double rtol,double atol,double dtol,int maxits);
   501)     
   502)     !Set up the KSP context
   503)     call KSPCreate(PETSC_COMM_SELF,KS,perr);CHKERRQ(perr)
   504) !    call KSPSetOperators(KS,A,A,SAME_PRECONDITIONER,perr)
   505)     call KSPSetOperators(KS,A,A,perr);CHKERRQ(perr)
   506)     call KSPGetPC(KS,P,perr);CHKERRQ(perr)
   507) !geh - begin
   508)     call KSPSetErrorIfNotConverged(KS,PETSC_TRUE,perr);CHKERRQ(perr)
   509) !geh - end
   510)     !call KSPSetType(KS,KSPGMRES,perr) !use default
   511)     !call KSPGMRESSetRestart(KS,1000,perr);
   512)     !call KSPGetTolerances(KS,rtol,atol,dtol,maxints,perr);CHKERRQ(perr)
   513)     call KSPSetTolerances(KS,rtol,atol,dtol,maxints,perr);CHKERRQ(perr)
   514)     call KSPSetFromOptions(KS,perr);CHKERRQ(perr)
   515) !geh - begin
   516)     ! this must come after KSPSetFromOptions (or PCSetFromOptions) as it is
   517)     ! overwritten by the defaults otherwise.
   518)     call PCFactorSetZeroPivot(P,1.d-40,perr);CHKERRQ(perr)
   519) !geh - end
   520)     
   521)   end subroutine build_ksp
   522)   !__________________________________________________________________
   523)  !____________________________________________________________________
   524)   subroutine forward_run
   525)     implicit none
   526)     integer :: i,m,n,niter,j,enum
   527)     integer, dimension(1) :: eindx
   528)     real, dimension(2) :: pck
   529)     PetscScalar :: val
   530)     real :: tstart, tend
   531)     
   532)     do i=1,my_ne
   533)        !call cpu_time(tstart)
   534)        
   535)        call VecGetArrayF90(psol,vloc,perr);CHKERRQ(perr)
   536)        vloc(1:nnodes)=dble(poles(:,i))
   537)        call VecRestoreArrayF90(psol,vloc,perr);CHKERRQ(perr)
   538)        enum=eind(my_rank,1)+i-1
   539)           
   540)        val=0.0
   541)        call VecSet(B,val,perr);CHKERRQ(perr)
   542)        
   543)        !if (i_flg) then
   544)        !   call Add_Jpp(i)
   545)        !end if
   546)        
   547)        eindx(1)=e_nods(enum)
   548)        val=1.0
   549)        call VecSetValues(B,1,eindx-1,val,ADD_VALUES,perr);CHKERRQ(perr)
   550) 
   551)        !if (tank_flag) call VecSetValues(B,1,i_zpot-1,-val,ADD_VALUES,perr);CHKERRQ(perr)
   552)            
   553)        call VecAssemblyBegin(B,perr);CHKERRQ(perr)
   554)        call VecAssemblyEnd(B,perr);CHKERRQ(perr)
   555)        
   556)        call KSPSolve(KS,B,psol,perr);CHKERRQ(perr)
   557)        !call KSPView(KS,PETSC_VIEWER_STDOUT_SELF,perr);CHKERRQ(perr)
   558) 
   559)        call VecGetArrayF90(psol,vloc,perr);CHKERRQ(perr)
   560)        poles(:,i)= real(vloc(1:nnodes))
   561)        call VecRestoreArrayF90(psol,vloc,perr);CHKERRQ(perr)
   562)       
   563)        call KSPGetIterationNumber(KS,niter,perr);CHKERRQ(perr)
   564)        !write(*,*) my_rank,niter
   565)        !call cpu_time(tend)
   566)        !pck(1)=tend-tstart
   567)        !pck(2)=real(niter)
   568)        !call MPI_SEND(pck,2,MPI_REAL,0,1,MPI_COMM_WORLD,perr)
   569)        !write(*,*) "Slave ",my_rank," solved for pole ",eind(my_rank,1)+i-1,'in ',tend-tstart,' seconds and ',niter,' iters'
   570)        
   571)     end do
   572)     
   573)     if (first_sol) then
   574)        call KSPSetInitialGuessNonzero(KS,PETSC_TRUE,perr);CHKERRQ(perr)
   575)        first_sol=.false.
   576)     end if
   577)     
   578)     call KSPDestroy(KS,perr);CHKERRQ(perr)
   579)     
   580)     
   581)   end subroutine forward_run
   582) !_________________________________________________________________________________________________
   583) 
   584) 
   585)    !__________________________________________________________________
   586)     subroutine send_dpred
   587)       implicit none
   588)       integer :: flg,i
   589)  
   590)       call assemble_data
   591)       call MPI_SEND(nmy_drows,1,MPI_INTEGER,0,0,E4D_COMM, ierr)
   592)       call MPI_SEND(my_drows,nmy_drows,MPI_INTEGER,0,0,E4D_COMM,ierr)
   593)       call MPI_SEND(my_dvals,nmy_drows,MPI_REAL,0,0,E4D_COMM,ierr)
   594)        
   595)     end subroutine send_dpred
   596)     !__________________________________________________________________
   597)      
   598)     !___________________________________________________________
   599)     subroutine assemble_data
   600)       implicit none
   601)       integer :: i,a,b,m,n,e1,e2,indx,p
   602)       
   603)       
   604)       e1=eind(my_rank,1)
   605)       e2=eind(my_rank,2) 
   606)       if (.not.allocated(my_drows)) then
   607)          nmy_drows=0
   608)          do i=1,nm
   609)             a=s_conf(i,1)
   610)             b=s_conf(i,2)
   611)             if ((a>=e1 .and. a<=e2) .or. (b>=e1.and. b<=e2)) then
   612)                nmy_drows=nmy_drows+1
   613)             end if
   614)          end do
   615)          allocate(my_drows(nmy_drows),my_dvals(nmy_drows))
   616)       end if
   617)       
   618)       indx=0
   619)       my_dvals=0
   620)       
   621)      
   622)       do i=1,nm
   623)          a = s_conf(i,1)
   624)          b = s_conf(i,2)
   625)          m = s_conf(i,3)
   626)          n = s_conf(i,4)
   627)          
   628)          if ((a>=e1 .and. a<=e2) .or. (b>=e1.and. b<=e2)) then
   629)             indx=indx+1
   630)             my_drows(indx)=i
   631)             
   632)             do p=e1,e2
   633)                if (p==a) then
   634)                   if (m.ne.0) my_dvals(indx)=my_dvals(indx) + real(poles(e_nods(m),a-e1+1))
   635)                   if (n.ne.0) my_dvals(indx)=my_dvals(indx) - real(poles(e_nods(n),a-e1+1))
   636)                end if
   637)                if (p==b) then
   638)                   if (m.ne.0) my_dvals(indx)=my_dvals(indx) - real(poles(e_nods(m),b-e1+1))
   639)                   if (n.ne.0) my_dvals(indx)=my_dvals(indx) + real(poles(e_nods(n),b-e1+1))
   640)                end if
   641)             end do
   642)          end if
   643)       end do
   644)      
   645)   end subroutine assemble_data
   646)   !___________________________________________________________  
   647)   !___________________________________________________________
   648)   subroutine cleanup
   649)   
   650)         if(allocated(e4d_ranks)) deallocate(e4d_ranks)
   651)         if(allocated(pf_e4d_ranks)) deallocate(pf_e4d_ranks)
   652)         if(allocated(map_inds)) deallocate(map_inds)
   653)         if(allocated(s_conf)) deallocate(s_conf)
   654)         if(allocated(eind)) deallocate(eind)
   655)         if(allocated(jind)) deallocate(jind)
   656)         if(allocated(nbounds)) deallocate(nbounds)
   657)         if(allocated(zones)) deallocate(zones)
   658)         if(allocated(elements)) deallocate(elements)
   659)         if(allocated(faces)) deallocate(faces)
   660)         if(allocated(e_nods)) deallocate(e_nods)
   661)         if(allocated(rows)) deallocate(rows)
   662)         if(allocated(cols)) deallocate(cols)
   663)         if(allocated(trows)) deallocate(trows)
   664)         if(allocated(tcols)) deallocate(tcols)
   665)         if(allocated(A_map)) deallocate(A_map)
   666)         if(allocated(S_map)) deallocate(S_map)
   667)         if(allocated(my_drows)) deallocate(my_drows)
   668)         if(allocated(e_pos)) deallocate(e_pos)
   669)         if(allocated(nodes)) deallocate(nodes)
   670)         if(allocated(poles)) deallocate(poles)
   671)         if(allocated(pf_tracer)) deallocate(pf_tracer)
   672)         if(allocated(pf_saturation)) deallocate(pf_saturation)
   673)         if(allocated(pf_saturation_0)) deallocate(pf_saturation_0)
   674)         if(allocated(sigma)) deallocate(sigma)
   675)         if(allocated(dpred)) deallocate(dpred)
   676)         if(allocated(dobs)) deallocate(dobs)
   677)         if(allocated(sd)) deallocate(sd)
   678)         if(allocated(my_dvals)) deallocate(my_dvals)
   679)         if(allocated(map)) deallocate(map)
   680)         if(allocated(base_sigma)) deallocate(base_sigma)
   681)         if(allocated(ffac)) deallocate(ffac)
   682)         if(allocated(pfxcb)) deallocate(pfxcb)
   683)         if(allocated(pfycb)) deallocate(pfycb)
   684)         if(allocated(pfzcb)) deallocate(pfzcb)
   685)         if(allocated(d_nnz)) deallocate(d_nnz)
   686)         if(allocated(delA)) deallocate(delA)
   687)   end subroutine cleanup
   688)   !___________________________________________________________
   689) end module e4d_run

generated by
Intel(R) C++/Fortran Compiler code-coverage tool
Web-Page Owner: Nobody