diff --git a/src/shared/exit_mpi.F90 b/src/shared/exit_mpi.F90 index 3f8a3ff80..8017e9a5f 100644 --- a/src/shared/exit_mpi.F90 +++ b/src/shared/exit_mpi.F90 @@ -83,7 +83,7 @@ subroutine stop_the_code(error_msg) implicit none - character(len=*) :: error_msg + character(len=*),intent(in) :: error_msg call exit_MPI(myrank,error_msg) diff --git a/src/shared/read_value_parameters.f90 b/src/shared/read_value_parameters.f90 index 8721919eb..08dfcd825 100644 --- a/src/shared/read_value_parameters.f90 +++ b/src/shared/read_value_parameters.f90 @@ -189,8 +189,8 @@ subroutine read_value_integer_p(value_to_read, name) implicit none - integer :: value_to_read - character(len=*) :: name + integer, intent(inout) :: value_to_read + character(len=*), intent(in) :: name character(len=MAX_STRING_LEN) :: string_read integer :: ierr common /param_err_common/ ierr @@ -209,8 +209,8 @@ subroutine read_value_double_precision_p(value_to_read, name) implicit none - double precision :: value_to_read - character(len=*) :: name + double precision, intent(inout) :: value_to_read + character(len=*), intent(in) :: name character(len=MAX_STRING_LEN) :: string_read integer :: ierr common /param_err_common/ ierr @@ -229,8 +229,8 @@ subroutine read_value_logical_p(value_to_read, name) implicit none - logical :: value_to_read - character(len=*) :: name + logical, intent(inout) :: value_to_read + character(len=*), intent(in) :: name character(len=MAX_STRING_LEN) :: string_read integer :: ierr common /param_err_common/ ierr @@ -249,8 +249,8 @@ subroutine read_value_string_p(value_to_read, name) implicit none - character(len=*) :: value_to_read - character(len=*) :: name + character(len=*), intent(inout) :: value_to_read + character(len=*), intent(in) :: name character(len=MAX_STRING_LEN) :: string_read integer :: ierr common /param_err_common/ ierr @@ -269,8 +269,8 @@ subroutine read_value_integer_next_p(value_to_read, name) implicit none - integer :: value_to_read - character(len=*) :: name + integer, intent(inout) :: value_to_read + character(len=*), intent(in) :: name character(len=MAX_STRING_LEN) :: string_read integer :: ierr common /param_err_common/ ierr @@ -289,8 +289,8 @@ subroutine read_value_double_prec_next_p(value_to_read, name) implicit none - double precision :: value_to_read - character(len=*) :: name + double precision, intent(inout) :: value_to_read + character(len=*), intent(in) :: name character(len=MAX_STRING_LEN) :: string_read integer :: ierr common /param_err_common/ ierr @@ -309,8 +309,8 @@ subroutine read_value_logical_next_p(value_to_read, name) implicit none - logical :: value_to_read - character(len=*) :: name + logical, intent(inout) :: value_to_read + character(len=*), intent(in) :: name character(len=MAX_STRING_LEN) :: string_read integer :: ierr common /param_err_common/ ierr diff --git a/src/shared/shared_par.F90 b/src/shared/shared_par.F90 index 508eb6591..2a7caa864 100644 --- a/src/shared/shared_par.F90 +++ b/src/shared/shared_par.F90 @@ -36,6 +36,8 @@ module constants + implicit none + include "constants.h" ! proc number for MPI process diff --git a/src/specfem2D/assemble_MPI.F90 b/src/specfem2D/assemble_MPI.F90 index b53e8ec29..06db7b875 100644 --- a/src/specfem2D/assemble_MPI.F90 +++ b/src/specfem2D/assemble_MPI.F90 @@ -1197,7 +1197,8 @@ subroutine assemble_MPI_vector_em_blocking(array_val) ipoin = 0 do i = 1, nibool_interfaces_electromagnetic(num_interface) - buffer_send_faces_vector_em(ipoin+1:ipoin+NDIM,iinterface) = array_val(:,ibool_interfaces_electromagnetic(i,num_interface)) + buffer_send_faces_vector_em(ipoin+1:ipoin+NDIM,iinterface) = & + array_val(:,ibool_interfaces_electromagnetic(i,num_interface)) ipoin = ipoin + NDIM enddo enddo @@ -1228,7 +1229,8 @@ subroutine assemble_MPI_vector_em_blocking(array_val) ipoin = 0 do i = 1, nibool_interfaces_electromagnetic(num_interface) array_val(:,ibool_interfaces_electromagnetic(i,num_interface)) = & - array_val(:,ibool_interfaces_electromagnetic(i,num_interface)) + buffer_recv_faces_vector_em(ipoin+1:ipoin+NDIM,iinterface) + array_val(:,ibool_interfaces_electromagnetic(i,num_interface)) & + + buffer_recv_faces_vector_em(ipoin+1:ipoin+NDIM,iinterface) ipoin = ipoin + NDIM enddo diff --git a/src/specfem2D/attenuation_model.f90 b/src/specfem2D/attenuation_model.f90 index 744559e78..8f94eb926 100644 --- a/src/specfem2D/attenuation_model.f90 +++ b/src/specfem2D/attenuation_model.f90 @@ -917,27 +917,27 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the integer, intent(in) :: Kopt double precision, intent(in) :: Qref,theta_min,theta_max,f_min,f_max - logical flg,flgc,flfc, constr, app, appconstr - logical FsbPnt, FsbPnt1, termflag, stopf - logical stopping, dispwarn, Reset, ksm,knan,obj - integer n, kstore, ajp,ajpp,knorms, k, kcheck, numelem - integer dispdata, ld, mxtc, termx, limxterm, nzero, krerun - integer warnno, kflat, stepvanish, i,j,ni,ii, kd,kj,kc,ip - integer iterlimit, kg,k1,k2, kless, allocerr - double precision options(13),doptions(13) - double precision x(n),f - double precision nsteps(3), gnorms(10), kk, nx - double precision ajb,ajs, des, dq,du20,du10,du03 - double precision n_float, cnteps - double precision low_bound, ZeroGrad, ddx, y - double precision lowxbound, lowfbound, detfr, detxr, grbnd - double precision fp,fp1,fc,f1,f2,fm,fopt,frec,fst, fp_rate - double precision PenCoef, PenCoefNew - double precision gamma,w,wdef,h1,h,hp - double precision dx,ng,ngc,nng,ngt,nrmz,ng1,d,dd, laststep - double precision zero,one,two,three,four,five,six,seven - double precision eight,nine,ten,hundr - double precision infty, epsnorm,epsnorm2,powerm12 + logical :: flg,flgc,flfc, constr, app, appconstr + logical :: FsbPnt, FsbPnt1, termflag, stopf + logical :: stopping, dispwarn, Reset, ksm,knan,obj + integer :: n, kstore, ajp,ajpp,knorms, k, kcheck, numelem + integer :: dispdata, ld, mxtc, termx, limxterm, nzero, krerun + integer :: warnno, kflat, stepvanish, i,j,ni,ii, kd,kj,kc,ip + integer :: iterlimit, kg,k1,k2, kless, allocerr + double precision :: options(13),doptions(13) + double precision :: x(n),f + double precision :: nsteps(3), gnorms(10), kk, nx + double precision :: ajb,ajs, des, dq,du20,du10,du03 + double precision :: n_float, cnteps + double precision :: low_bound, ZeroGrad, ddx, y + double precision :: lowxbound, lowfbound, detfr, detxr, grbnd + double precision :: fp,fp1,fc,f1,f2,fm,fopt,frec,fst, fp_rate + double precision :: PenCoef, PenCoefNew + double precision :: gamma,w,wdef,h1,h,hp + double precision :: dx,ng,ngc,nng,ngt,nrmz,ng1,d,dd, laststep + double precision :: zero,one,two,three,four,five,six,seven + double precision :: eight,nine,ten,hundr + double precision :: infty, epsnorm,epsnorm2,powerm12 double precision, dimension(:,:), allocatable :: B double precision, dimension(:), allocatable :: g double precision, dimension(:), allocatable :: g0 @@ -961,7 +961,8 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the ten/1.d1/, hundr/1.d2/, powerm12/1.d-12/, & infty /1.d100/, epsnorm /1.d-15/, epsnorm2 /1.d-30/, & allocerrstr/'Allocation Error = '/ -! Check the dimension: + + ! Check the dimension: if (n < 2) then print *, 'SolvOpt error:' print *, 'Improper space dimension.' @@ -970,7 +971,8 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the goto 999 endif n_float=dble(n) -! allocate working arrays: + + ! allocate working arrays: allocate (B(n,n),stat=allocerr) if (allocerr /= 0) then options(9)=-one @@ -1056,11 +1058,12 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the call stop_the_code('error in allocate statement in SolvOpt') endif -! store flags: + ! store flags: app= .not. flg constr = flfc appconstr= .not. flgc -! Default values for options: + + ! Default values for options: call soptions(doptions) do i = 1,8 if (options(i) == zero) then @@ -1074,7 +1077,7 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the endif enddo -! WORKING CONSTANTS AND COUNTERS ----{ + ! WORKING CONSTANTS AND COUNTERS ----{ options(10)=zero !! counter for function calculations options(11)=zero !! counter for gradient calculations @@ -1090,7 +1093,7 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the k = 0 !! Iteration counter wdef=one/options(7)-one !! Default space transf. coeff. -! Gamma control ---{ + ! Gamma control ---{ ajb = one+1.d-1/n_float**2 !! Base I ajp = 20 ajpp = ajp !! Start value for the power @@ -1099,8 +1102,9 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the do i = 1,10 gnorms(i)=zero enddo -!---} -! Display control ---{ + !---} + + ! Display control ---{ if (options(5) <= zero) then dispdata = 0 if (options(5) == -one) then @@ -1113,9 +1117,9 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the dispwarn = .true. endif ld = dispdata -!---} + !---} -! Stepsize control ---{ + ! Stepsize control ---{ dq=5.1d0 !! Step divider (at f_{i+1} > gamma*f_{i}) du20 = two du10 = 1.5d0 @@ -1130,19 +1134,24 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the des = 3.3d0 endif mxtc=3 !! Number of trial cycles (steep wall detect) -!---} + !---} + termx = 0 limxterm = 50 !! Counter and limit for x-criterion -! stepsize for gradient approximation + + ! stepsize for gradient approximation ddx = dmax1(1.d-11,options(8)) low_bound=-one+1.d-4 !! Lower bound cosine used to detect a ravine ZeroGrad = n_float*1.d-16 !! Lower bound for a gradient norm nzero = 0 !! Zero-gradient events counter -! Low bound for the values of variables to take into account + + ! Low bound for the values of variables to take into account lowxbound = dmax1(options(2),1.d-3) -! Lower bound for function values to be considered as making difference + + ! Lower bound for function values to be considered as making difference lowfbound=options(3)**2 + krerun = 0 !! Re-run events counter detfr=options(3)*hundr !! Relative error for f/f_{record} detxr = options(2)*ten !! Relative error for norm(x)/norm(x_{record}) @@ -1150,10 +1159,11 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the kflat = 0 !! counter for points of flatness stepvanish = 0 !! counter for vanished steps stopf = .false. -! ----} End of setting constants -! ----} End of the preamble -!-------------------------------------------------------------------- -! Compute the function ( first time ) ----{ + ! ----} End of setting constants + ! ----} End of the preamble + + !-------------------------------------------------------------------- + ! Compute the function ( first time ) ----{ call fun(x,f,Qref,n/2,n,Kopt,f_min,f_max) options(10)=options(10)+one if (dabs(f) >= infty) then @@ -1168,7 +1178,8 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the xrec(i)=x(i) enddo frec = f !! record point and function value -! Constrained problem + + ! Constrained problem if (constr) then kless = 0 fp = f @@ -1191,8 +1202,9 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the endif f = f+PenCoef*fc endif -! ----} -! COMPUTE THE GRADIENT ( FIRST TIME ) ----{ + ! ----} + + ! COMPUTE THE GRADIENT ( FIRST TIME ) ----{ if (app) then do i = 1,n deltax(i)=h1*ddx @@ -1279,8 +1291,9 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the grec(i)=g(i) enddo nng = ng -! ----} -! INITIAL STEP SIZE + ! ----} + + ! INITIAL STEP SIZE d = zero do i = 1,n if (d < dabs(x(i))) d = dabs(x(i)) @@ -1292,7 +1305,7 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the h = h1*dmax1(one/dlog(ng+1.1d0),dabs(h)) !! calculated stepsize endif -! RESETTING LOOP ----{ + ! RESETTING LOOP ----{ do while (.true.) kcheck = 0 !! Set checkpoint counter. kg = 0 !! stepsizes stored @@ -1306,18 +1319,20 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the enddo fst = f dx = 0 -! ----} + ! ----} -! MAIN ITERATIONS ----{ + ! MAIN ITERATIONS ----{ do while (.true.) k = k+1 kcheck = kcheck+1 laststep = dx -! ADJUST GAMMA --{ - gamma = one+dmax1(ajb**((ajp-kcheck)*n),two*options(3)) - gamma = dmin1 ( gamma,ajs**dmax1(one,dlog10(nng+one)) ) -! --} + + ! ADJUST GAMMA --{ + gamma = one+dmax1(ajb**((ajp-kcheck)*n),two*options(3)) + gamma = dmin1 ( gamma,ajs**dmax1(one,dlog10(nng+one)) ) + ! --} + ngt = zero ng1 = zero dd = zero @@ -1336,7 +1351,8 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the dd = dd/ngt/ng1 w = wdef -! JUMPING OVER A RAVINE ----{ + + ! JUMPING OVER A RAVINE ----{ if (dd < low_bound) then if (kj == 2) then do i = 1,n @@ -1363,8 +1379,9 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the else kj = 0 endif -! ----} -! DILATION ----{ + ! ----} + + ! DILATION ----{ nrmz = zero do i = 1,n z(i)=gt(i)-g1(i) @@ -1375,8 +1392,9 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the do i = 1,n z(i)=z(i)/nrmz enddo -! New direction in the transformed space: g1=gt+w*(z*gt')*z and -! new inverse matrix: B = B ( I + (1/alpha -1)zz' ) + + ! New direction in the transformed space: g1=gt+w*(z*gt')*z and + ! new inverse matrix: B = B ( I + (1/alpha -1)zz' ) d = zero do i = 1,n d = d+z(i)*gt(i) @@ -1413,8 +1431,9 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the enddo g0(i)=d enddo -! ----} -! RESETTING ----{ + ! ----} + + ! RESETTING ----{ if (kcheck > 1) then numelem = 0 do i = 1,n @@ -1445,8 +1464,9 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the endif endif endif -! ----} -! STORE THE CURRENT VALUES AND SET THE COUNTERS FOR 1-D SEARCH + ! ----} + + ! STORE THE CURRENT VALUES AND SET THE COUNTERS FOR 1-D SEARCH do i = 1,n xopt(i)=x(i) enddo @@ -1458,7 +1478,8 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the knan = .false. hp = h if (constr) Reset = .false. -! 1-D SEARCH ----{ + + ! 1-D SEARCH ----{ do while (.true.) do i = 1,n x1(i)=x(i) @@ -1468,7 +1489,7 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the FsbPnt1 = FsbPnt fp1 = fp endif -! NEW POINT + ! NEW POINT do i = 1,n x(i)=x(i)+hp*g0(i) enddo @@ -1476,7 +1497,7 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the do i = 1,n if (dabs(x(i)-x1(i)) < dabs(x(i))*epsnorm) ii = ii+1 enddo -! function value + ! function value call fun(x,f,Qref,n/2,n,Kopt,f_min,f_max) options(10)=options(10)+one if (h1*f >= infty) then @@ -1545,7 +1566,7 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the fp = fp1 endif endif -! STEP SIZE IS ZERO TO THE EXTENT OF EPSNORM + ! STEP SIZE IS ZERO TO THE EXTENT OF EPSNORM else if (ii == n) then stepvanish = stepvanish+1 if (stepvanish >= 5) then @@ -1567,7 +1588,7 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the fp = fp1 endif endif -! USE SMALLER STEP + ! USE SMALLER STEP else if (h1*f < h1*gamma**idint(dsign(one,f1))*f1) then if (ksm) exit k2 = k2+1 @@ -1582,10 +1603,10 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the fp = fp1 endif if (kc >= mxtc) exit -! 1-D OPTIMIZER IS LEFT BEHIND + ! 1-D OPTIMIZER IS LEFT BEHIND else if (h1*f <= h1*f1) exit -! USE LARGER STEP + ! USE LARGER STEP k1 = k1+1 if (k2 > 0) kc=kc+1 k2 = 0 @@ -1598,8 +1619,9 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the endif endif enddo -! ----} End of 1-D search -! ADJUST THE TRIAL STEP SIZE ----{ + ! ----} End of 1-D search + + ! ADJUST THE TRIAL STEP SIZE ----{ dx = zero do i = 1,n dx = dx+(xopt(i)-x(i))**2 @@ -1636,8 +1658,9 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the endif if (ksm) stepvanish=stepvanish+1 -! ----} -! COMPUTE THE GRADIENT ----{ + ! ----} + + ! COMPUTE THE GRADIENT ----{ if (app) then do j = 1,n if (g0(j) >= zero) then @@ -1676,7 +1699,7 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the endif ng = ZeroGrad endif -! Constraints: + ! Constraints: if (constr) then if (.not. FsbPnt) then if (ng < 1.d-2*PenCoef) then @@ -1749,7 +1772,8 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the grec(i)=g(i) enddo endif -! ----} + ! ----} + if (ng > ZeroGrad) then if (knorms < 10) knorms=knorms+1 if (knorms >= 2) then @@ -1764,14 +1788,14 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the enddo nng = nng**(one/dble(knorms)) endif -! Norm X: + ! Norm X: nx = zero do i = 1,n nx = nx+x(i)*x(i) enddo nx=dsqrt(nx) -! DISPLAY THE CURRENT VALUES ----{ + ! DISPLAY THE CURRENT VALUES ----{ if (k == ld) then print *, & 'Iteration # ..... function value ..... ', & @@ -1779,15 +1803,16 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the print '(5x,i5,7x,g13.5,6x,g13.5,7x,g13.5)', k,f,dx,ng ld = k+dispdata endif -!----} -! CHECK THE STOPPING CRITERIA ----{ + !----} + + ! CHECK THE STOPPING CRITERIA ----{ termflag = .true. if (constr) then if (.not. FsbPnt) termflag = .false. endif if (kcheck <= 5 .or. kcheck <= 12 .and. ng > one)termflag = .false. if (kc >= mxtc .or. knan)termflag = .false. -! ARGUMENT + ! ARGUMENT if (termflag) then ii = 0 stopping = .true. @@ -1808,7 +1833,7 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the d = d+(x(i)-xrec(i))**2 enddo d=dsqrt(d) -! function + ! function if (dabs(f-frec) > detfr*dabs(f) .and. & dabs(f-fopt) <= options(3)*dabs(f) .and. & krerun <= 3 .and. .not. constr) then @@ -1896,7 +1921,7 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the endif endif endif -! ITERATIONS LIMIT + ! ITERATIONS LIMIT if (k == iterlimit) then options(9)=-nine if (dispwarn) then @@ -1905,8 +1930,8 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the endif goto 999 endif -! ----} -! ZERO GRADIENT ----{ + ! ----} + ! ZERO GRADIENT ----{ if (constr) then if (ng <= ZeroGrad) then if (dispwarn) then @@ -1985,8 +2010,9 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the exit endif endif -! ----} -! function is flat at the point ----{ + ! ----} + + ! function is flat at the point ----{ if (.not. constr .and. & dabs(f-fopt) < dabs(fopt)*options(3) .and. kcheck > 5 .and. ng < one) then @@ -2069,14 +2095,15 @@ subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,the endif !! a better value has been found endif !! function is flat endif !! pre-conditions are fulfilled -! ----} + ! ----} + enddo !! iterations enddo !! restart 999 continue -! deallocate working arrays: - deallocate (idx,deltax,xx,grec,xrec,xopt,x1,z,gc,gt,g1,g0,g,B) + ! deallocate working arrays: + deallocate (idx,deltax,xx,grec,xrec,xopt,x1,z,gc,gt,g1,g0,g,B) end subroutine solvopt diff --git a/src/specfem2D/define_external_model_from_tomo_file.f90 b/src/specfem2D/define_external_model_from_tomo_file.f90 index aa567986e..7f14e6ba9 100644 --- a/src/specfem2D/define_external_model_from_tomo_file.f90 +++ b/src/specfem2D/define_external_model_from_tomo_file.f90 @@ -74,6 +74,8 @@ module interpolation ! (modified from http://www.shocksolution.com) ! ---------------------------------------------------------------------------------------- + implicit none + contains ! ====================== Implementation part =============== diff --git a/src/specfem2D/enforce_fields.f90 b/src/specfem2D/enforce_fields.f90 index 468451de3..1ee91a1ea 100644 --- a/src/specfem2D/enforce_fields.f90 +++ b/src/specfem2D/enforce_fields.f90 @@ -60,11 +60,11 @@ module enforce_par function count_lines(filename) result(nlines) implicit none - character(len=*) :: filename + character(len=*), intent(in) :: filename integer :: nlines integer :: io - open(10,file=filename, iostat=io, status='old') + open(10,file=trim(filename), iostat=io, status='old') if (io /= 0) call stop_the_code('Cannot open file! ') nlines = 0 diff --git a/src/specfem2D/prepare_attenuation.f90 b/src/specfem2D/prepare_attenuation.f90 index 6837931a8..0310d1c47 100644 --- a/src/specfem2D/prepare_attenuation.f90 +++ b/src/specfem2D/prepare_attenuation.f90 @@ -293,7 +293,7 @@ subroutine prepare_attenuation() write(IMAIN,*) call flush_IMAIN() endif - + ! precompute Runge Kutta coefficients if viscous attenuation ! viscous attenuation is implemented following the memory variable formulation of ! J. M. Carcione Wave fields in real media: wave propagation in anisotropic, diff --git a/src/specfem2D/prepare_source_time_function.f90 b/src/specfem2D/prepare_source_time_function.f90 index 199ffb2a8..92dcb03ab 100644 --- a/src/specfem2D/prepare_source_time_function.f90 +++ b/src/specfem2D/prepare_source_time_function.f90 @@ -54,7 +54,7 @@ subroutine prepare_source_time_function() integer :: it,i_source,ier,num_file integer :: i_stage - character(len=150) :: error_msg1 = 'Error opening the file that contains the external source: ' + character(len=150),parameter :: error_msg1 = 'Error opening the file that contains the external source: ' character(len=250) :: error_msg logical :: trick_ok diff --git a/src/specfem2D/read_mesh_databases.F90 b/src/specfem2D/read_mesh_databases.F90 index 98628e98d..22202ede0 100644 --- a/src/specfem2D/read_mesh_databases.F90 +++ b/src/specfem2D/read_mesh_databases.F90 @@ -1682,6 +1682,7 @@ subroutine process_seismotype_line() interface subroutine AddToList(list, element) + implicit none integer, dimension(:), allocatable, intent(inout) :: list integer, intent(in) :: element end subroutine AddToList @@ -1748,9 +1749,10 @@ subroutine StripChar(string,char) implicit none character(len=*),intent(inout) :: string - character(len=512) :: stringCopy1, stringCopy2 character,intent(in) :: char + character(len=512) :: stringCopy1, stringCopy2 + if (char == ' ') then stop 'This function can not be used to strip spaces, use StripSpaces instead' endif @@ -1773,7 +1775,8 @@ subroutine StripSpaces(string) implicit none - character(len=*) :: string + character(len=*),intent(inout) :: string + integer :: stringLen integer :: last, actual @@ -1805,11 +1808,11 @@ subroutine AddToList(list, element) implicit none - integer :: i, isize integer, intent(in) :: element integer, dimension(:), allocatable, intent(inout) :: list - integer, dimension(:), allocatable :: clist + integer :: i, isize + integer, dimension(:), allocatable :: clist if (allocated(list)) then isize = size(list)