1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
|
[...]
do ntime= ntime_deb, Tdomain%TimeD%NtimeMax-1
!before newmark the current time of Displ etc is ntime, after newmark, it is ntime+1
!if (ntime==2000) then
Tdomain%test_flag=.true.
!else
!Tdomain%test_flag=.false.
!endif
Tdomain%TimeD%rtime = Tdomain%TimeD%rtime + Tdomain%TimeD%dtmin
Tdomain%TimeD%itime=ntime
call Newmark (Tdomain)
if (Tdomain%logicD%save_snapshots .or. Tdomain%logicD%save_deformation) i_snap = mod (ntime, Tdomain%TimeD%nsnap)
if (Tdomain%save_for_inversion) call save_wf(Tdomain)
if (i_snap == 0 ) then
if (Tdomain%MPI_var%my_rank == 0) write (*,*) "Iteration number ", ntime
if (Tdomain%logicD%save_snapshots) call savefield (Tdomain,ntime,is_save)
if (Tdomain%logicD%save_deformation) then
call save_vorticity (Tdomain,ntime,is_save)
call save_deformation (Tdomain, ntime,is_save)
endif
! if (Tdomain%logicD%save_fault_trace) call save_fault_trace (Tdomain, ntime)
endif
if (Tdomain%logicD%save_trace) call save_trace(Tdomain, ntime,is_save)
if (Tdomain%trmd.and.mod(ntime,Tdomain%TimeD%nsamp)==0) call dump_trm_direct_fields(Tdomain)
if (Tdomain%debugflag) then
call maxfield(Tdomain,ntime,maxf,0)
if (Tdomain%Mpi_var%my_rank==0) print*,'debugflag on:',ntime,maxf,Tdomain%debuglevel
if (maxf>Tdomain%debuglevel) then
print*,'maxf>Tdomain%debuglevel',maxf,Tdomain%debuglevel
call savefield (Tdomain,ntime,is_save)
call MPI_FINALIZE(ierr)
stop 'leveldebug has been reached ... exit.'
endif
endif
if (ntime/=ntime_deb.and.Tdomain%backupflag &
.and.((mod(ntime,Tdomain%TimeD%backupsamp)==0) &
.or.ntime==Tdomain%TimeD%NtimeMax-1)) call checkpoint(ntime,Tdomain)
!if (Tdomain%Mpi_var%my_rank==Tdomain%Mpi_var%smallestrankwithtrace.and.mod(ntime,10)==0) then
!t22=mpi_wtime()
!print*,'ntime=',ntime,Tdomain%TimeD%NtimeMax-1,sngl(t22-t12),sngl(maxval(abs(Tdomain%Store_Trace)))
!t12=t22
!endif
if (mod(ntime,Tdomain%TimeD%nsamp)==0) then
if (Tdomain%n_receivers_in>0) then
tmpv=maxval(abs(Tdomain%Store_Trace(:,:,ntime/Tdomain%TimeD%nsamp)))
else
tmpv=0.
endif
call MPI_REDUCE(tmpv,tmpvv,1,MPI_DOUBLE_PRECISION,MPI_MAX,0,MPI_COMM_WORLD,ierr)
if (Tdomain%Mpi_var%my_rank==0) then
t22=mpi_wtime()
print*,'ntime=',ntime+1,Tdomain%TimeD%NtimeMax-1,sngl(t22-t12),sngl(tmpvv)
itav=itav+1; tav=tav+t22-t12
if (sngl(tmpvv)>1.d40) STOP 'The code is unstable!'
t12=t22
endif
inquire(file="stop_in_run",exist=flag)
if (flag) then
if (Tdomain%MPI_var%my_rank == 0) then
print*,'Stoping at time=',Tdomain%TimeD%rtime
print*,'Stop in run requested, but checkingpoint first'
endif
if (Tdomain%backupflag) call checkpoint(ntime,Tdomain)
call MPI_Finalize (ierr)
STOP "Exit requested by user done!"
endif
endif
if (Tdomain%adjoint) call update_kernel(Tdomain)
call progress(ntime,Tdomain%TimeD%NtimeMax-1) !! progress bar
enddo
[...]
end program
!!!! progress bar subroutine : !!!!
subroutine progress(NbrEval,NbrEvalTot)
implicit none
integer(kind=4) :: k,NbTics,NbrEvalTot,NbrEval
integer, save :: NbTicsPrec = 0
NbrEval = NbrEval + 1
NbTics = 50.0 * real(NbrEval) / real(NbrEvalTot)
do k = NbTicsPrec + 1, NbTics
if (mod(k,5) == 0) then
write(0,'(i0)',advance='no') k / 5
else
write(0,'(a)',advance='no') '-'
end if
enddo
NbTicsPrec = NbTics
return
end |
Partager