diff --git a/EXAMPLES/BENCHMARK_CLAERBOUT_ADJOINT/ACOUSTIC/adj_seismogram.f90 b/EXAMPLES/BENCHMARK_CLAERBOUT_ADJOINT/ACOUSTIC/adj_seismogram.f90 index 469605add..ab7de18e0 100644 --- a/EXAMPLES/BENCHMARK_CLAERBOUT_ADJOINT/ACOUSTIC/adj_seismogram.f90 +++ b/EXAMPLES/BENCHMARK_CLAERBOUT_ADJOINT/ACOUSTIC/adj_seismogram.f90 @@ -22,7 +22,7 @@ program adj_seismogram write(procname,"(i4)") myrank !! input parameters - if( iargc() /= 2 ) stop 'Usage: ./xadj NSTEP DT' + if ( iargc() /= 2 ) stop 'Usage: ./xadj NSTEP DT' j=1; call getarg(j, arg); read(arg,*,iostat=ios) NSTEP; if (ios /= 0) stop 'Error reading NSTEP' j=2; call getarg(j, arg); read(arg,*,iostat=ios) DT; if (ios /= 0) stop 'Error reading DT' @@ -50,13 +50,13 @@ program adj_seismogram filename=trim(adjustl(procname))//"_dx_SU" open(111,file="../OUTPUT_FILES/SEM/syn/"//trim(filename), & status='old',access='direct',action='read',recl=240+4*NSTEP,iostat = ios) - if( ios /= 0 ) stop 'error opening file syn' + if ( ios /= 0 ) stop 'error opening file syn' open(112,file="../OUTPUT_FILES/SEM/dat/"//trim(filename), & status='old',access='direct',action='read',recl=240+4*NSTEP,iostat = ios) - if( ios /= 0 ) stop 'error opening file dat' + if ( ios /= 0 ) stop 'error opening file dat' open(113,file="../OUTPUT_FILES/SEM/"//trim(filename)//".adj", & status='unknown',access='direct',action='write',recl=240+4*NSTEP,iostat = ios) - if( ios /= 0 ) stop 'error opening file .adj' + if ( ios /= 0 ) stop 'error opening file .adj' irec=1 do while(ios==0) @@ -73,7 +73,7 @@ program adj_seismogram if (ios /= 0) exit !daniel: outputs ascii trace - if( myrank == 0 .and. irec == 196 ) then + if ( myrank == 0 .and. irec == 196 ) then open(221,file="../OUTPUT_FILES/SEM/syn/"//trim(filename)//".ascii",status='unknown') do i=1,NSTEP write(221,*) i,syn(i) @@ -101,13 +101,13 @@ program adj_seismogram filename=trim(adjustl(procname))//"_dy_SU" open(111,file="../OUTPUT_FILES/SEM/syn/"//trim(filename), & status='old',access='direct',action='read',recl=240+4*NSTEP,iostat = ios) - if( ios /= 0 ) stop 'error opening file syn' + if ( ios /= 0 ) stop 'error opening file syn' open(112,file="../OUTPUT_FILES/SEM/dat/"//trim(filename), & status='old',access='direct',action='read',recl=240+4*NSTEP,iostat = ios) - if( ios /= 0 ) stop 'error opening file dat' + if ( ios /= 0 ) stop 'error opening file dat' open(113,file="../OUTPUT_FILES/SEM/"//trim(filename)//".adj", & status='unknown',access='direct',action='write',recl=240+4*NSTEP,iostat = ios) - if( ios /= 0 ) stop 'error opening file .adj' + if ( ios /= 0 ) stop 'error opening file .adj' irec=1 do while(ios==0) @@ -123,7 +123,7 @@ program adj_seismogram if (ios /= 0) exit !daniel: outputs ascii trace - if( myrank == 0 .and. irec == 196 ) then + if ( myrank == 0 .and. irec == 196 ) then open(221,file="../OUTPUT_FILES/SEM/syn/"//trim(filename)//".ascii",status='unknown') do i=1,NSTEP write(221,*) i,syn(i) @@ -152,13 +152,13 @@ program adj_seismogram filename=trim(adjustl(procname))//"_dz_SU" open(111,file="../OUTPUT_FILES/SEM/syn/"//trim(filename), & status='old',access='direct',action='read',recl=240+4*NSTEP,iostat = ios) - if( ios /= 0 ) stop 'error opening file syn' + if ( ios /= 0 ) stop 'error opening file syn' open(112,file="../OUTPUT_FILES/SEM/dat/"//trim(filename), & status='old',access='direct',action='read',recl=240+4*NSTEP,iostat = ios) - if( ios /= 0 ) stop 'error opening file dat' + if ( ios /= 0 ) stop 'error opening file dat' open(113,file="../OUTPUT_FILES/SEM/"//trim(filename)//".adj", & status='unknown',access='direct',action='write',recl=240+4*NSTEP,iostat = ios) - if( ios /= 0 ) stop 'error opening file .adj' + if ( ios /= 0 ) stop 'error opening file .adj' irec=1 do while(ios==0) @@ -173,7 +173,7 @@ program adj_seismogram if (ios /= 0) exit !daniel: outputs ascii trace - if( myrank == 0 .and. irec == 196 ) then + if ( myrank == 0 .and. irec == 196 ) then open(221,file="../OUTPUT_FILES/SEM/syn/"//trim(filename)//".ascii",status='unknown') do i=1,NSTEP write(221,*) i,syn(i) diff --git a/EXAMPLES/BENCHMARK_CLAERBOUT_ADJOINT/ACOUSTIC/postprocessing.f90 b/EXAMPLES/BENCHMARK_CLAERBOUT_ADJOINT/ACOUSTIC/postprocessing.f90 index a2ce0d1ec..796b27eab 100644 --- a/EXAMPLES/BENCHMARK_CLAERBOUT_ADJOINT/ACOUSTIC/postprocessing.f90 +++ b/EXAMPLES/BENCHMARK_CLAERBOUT_ADJOINT/ACOUSTIC/postprocessing.f90 @@ -14,7 +14,7 @@ program random_model real(kind=4),dimension(:), allocatable :: adj !! input parameters - if( iargc() /= 3 ) stop 'Usage: ./xpostprocessing NSTEP DT NPROC' + if ( iargc() /= 3 ) stop 'Usage: ./xpostprocessing NSTEP DT NPROC' j=1; call getarg(j, arg); read(arg,*,iostat=ios) NSTEP; if (ios /= 0) stop 'Error reading NSTEP' j=2; call getarg(j, arg); read(arg,*,iostat=ios) DT; if (ios /= 0) stop 'Error reading DT' j=3; call getarg(j, arg); read(arg,*,iostat=ios) NPROC; if (ios /= 0) stop 'Error reading NPROC' @@ -40,33 +40,33 @@ program random_model ! nspec & nglob open(unit=IOUT,file='./OUTPUT_FILES/DATABASES_MPI/'//trim(adjustl(prname))//'external_mesh.bin',status='old',action='read',form='unformatted',iostat=ier) - if( ier /= 0 ) stop 'error opening database proc######_external_mesh.bin' + if ( ier /= 0 ) stop 'error opening database proc######_external_mesh.bin' read(IOUT) nspec read(IOUT) nglob close(IOUT) ! weights - allocate(weights(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array weights' + allocate(weights(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array weights' open(unit=IOUT,file='./OUTPUT_FILES/DATABASES_MPI/'//trim(adjustl(prname))//'weights_kernel.bin',status='old',action='read',form='unformatted',iostat=ier) read(IOUT) weights close(IOUT) ! kernels - allocate(krhop(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array krhop' + allocate(krhop(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array krhop' open(unit=IOUT,file='./OUTPUT_FILES/DATABASES_MPI/'//trim(adjustl(prname))//'rhop_acoustic_kernel.bin',status='old',action='read',form='unformatted',iostat=ier) read(IOUT) krhop close(IOUT) - allocate(kalpha(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array kalpha' + allocate(kalpha(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array kalpha' open(unit=IOUT,file='./OUTPUT_FILES/DATABASES_MPI/'//trim(adjustl(prname))//'alpha_acoustic_kernel.bin',status='old',action='read',form='unformatted',iostat=ier) read(IOUT) kalpha close(IOUT) - allocate(kbeta(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array kbeta' + allocate(kbeta(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array kbeta' ! rho - allocate(rho(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array rho' - allocate(rho0(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array rho0' + allocate(rho(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array rho' + allocate(rho0(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array rho0' open(unit=IOUT,file='./models/target_model/'//trim(adjustl(prname))//'rho.bin',status='old',action='read',form='unformatted') read(IOUT) rho close(IOUT) @@ -75,8 +75,8 @@ program random_model close(IOUT) ! vp - allocate(vp(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array vp' - allocate(vp0(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array vp0' + allocate(vp(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array vp' + allocate(vp0(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array vp0' open(unit=IOUT,file='./models/target_model/'//trim(adjustl(prname))//'vp.bin',status='old',action='read',form='unformatted') read(IOUT) vp close(IOUT) @@ -85,8 +85,8 @@ program random_model close(IOUT) ! vs - allocate(vs(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array vs' - allocate(vs0(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array vs0' + allocate(vs(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array vs' + allocate(vs0(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array vs0' ! F dm = S(m+dm) - S(m), we backpropogate syn-dat (see adj_seismogram.f90) => we have to add a minus sign in front of kernels MODELSPACE=MODELSPACE + & @@ -100,7 +100,7 @@ program random_model write(procname,"(i4)") myrank filename=trim(adjustl(procname))//"_dx_SU" open(111,file="./OUTPUT_FILES/SEM/"//trim(adjustl(filename))//".adj",access='direct',recl=240+4*NSTEP,iostat = ios) - if( ios /= 0 ) stop 'error opening adjoint trace' + if ( ios /= 0 ) stop 'error opening adjoint trace' print *,' ',trim(adjustl(filename))//".adj" irec=1 @@ -120,7 +120,7 @@ program random_model !elastic case ! filename=trim(adjustl(procname))//"_dy_SU" ! open(111,file="../OUTPUT_FILES/SEM/"//trim(adjustl(filename))//".adj",access='direct',recl=240+4*NSTEP,iostat = ios) -! if( ios /= 0 ) stop 'error opening adjoint trace' +! if ( ios /= 0 ) stop 'error opening adjoint trace' ! print *,' ',trim(adjustl(filename))//".adj" ! ! irec=1 @@ -138,7 +138,7 @@ program random_model ! ! filename=trim(adjustl(procname))//"_dz_SU" ! open(111,file="../OUTPUT_FILES/SEM/"//trim(adjustl(filename))//".adj",access='direct',recl=240+4*NSTEP,iostat = ios) -! if( ios /= 0 ) stop 'error opening adjoint trace' +! if ( ios /= 0 ) stop 'error opening adjoint trace' ! print *,' ',trim(adjustl(filename))//".adj" ! ! irec=1 diff --git a/EXAMPLES/BENCHMARK_CLAERBOUT_ADJOINT/ACOUSTIC/random_model_generation.f90 b/EXAMPLES/BENCHMARK_CLAERBOUT_ADJOINT/ACOUSTIC/random_model_generation.f90 index 2f7969743..eff4aac7e 100644 --- a/EXAMPLES/BENCHMARK_CLAERBOUT_ADJOINT/ACOUSTIC/random_model_generation.f90 +++ b/EXAMPLES/BENCHMARK_CLAERBOUT_ADJOINT/ACOUSTIC/random_model_generation.f90 @@ -31,24 +31,24 @@ program random_model call MPI_Comm_Size(MPI_COMM_WORLD,NPROC,ier) !! input parameters - if( iargc() /= 1 ) stop 'Usage: ./xrandom_model percent [must be small enough (~1d-5) for F*dm=S(m+dm)-S(m) to be valid]' + if ( iargc() /= 1 ) stop 'Usage: ./xrandom_model percent [must be small enough (~1d-5) for F*dm=S(m+dm)-S(m) to be valid]' j=1; call getarg(j, arg); read(arg,*,iostat=ios) percent; if (ios /= 0) stop 'Error reading percent' ! processors name write(prname,'(a,i6.6,a)') trim(LOCAL_PATH)//'proc',myrank,'_' ! nspec & nglob open(unit=IOUT,file=trim(adjustl(prname))//'external_mesh.bin',status='old',action='read',form='unformatted',iostat=ier) - if( ier /= 0 ) stop 'error opening database proc######_external_mesh.bin' + if ( ier /= 0 ) stop 'error opening database proc######_external_mesh.bin' read(IOUT) nspec read(IOUT) nglob ! ibool file allocate(ibool(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) - if( ier /= 0 ) stop 'error allocating array ibool' + if ( ier /= 0 ) stop 'error allocating array ibool' read(IOUT) ibool ! global point arrays allocate(xstore(nglob),ystore(nglob),zstore(nglob),stat=ier) - if( ier /= 0 ) stop 'error allocating array xstore etc.' + if ( ier /= 0 ) stop 'error allocating array xstore etc.' read(IOUT) xstore read(IOUT) ystore read(IOUT) zstore @@ -56,18 +56,18 @@ program random_model close(IOUT) ! rho - allocate( rho_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array rho_read' + allocate( rho_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array rho_read' open(unit=IOUT,file=trim(adjustl(prname))//'rho.bin',status='old',action='read',form='unformatted') read(IOUT) rho_read close(IOUT) ! vp - allocate( vp_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array vp_read' + allocate( vp_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array vp_read' open(unit=IOUT,file=trim(adjustl(prname))//'vp.bin',status='old',action='read',form='unformatted') read(IOUT) vp_read close(IOUT) ! vs - allocate( vs_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array vs_read' + allocate( vs_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array vs_read' open(unit=IOUT,file=trim(adjustl(prname))//'vs.bin',status='old',action='read',form='unformatted') read(IOUT) vs_read close(IOUT) @@ -77,9 +77,9 @@ program random_model ! question: is the signal sensitive to this perturbation? or is it within numerical noise/artefacts? ! perturb model randomly - allocate( random(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array random' + allocate( random(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array random' - if( .false. ) then + if ( .false. ) then CALL RANDOM_SEED() @@ -110,7 +110,7 @@ program random_model ! adds a Gaussian perturbation in the middle of the model - if( .true. ) then + if ( .true. ) then ! initializes perturbations random(:,:,:,:) = 0.0 @@ -122,7 +122,7 @@ program random_model sigma_h2 = 2.0 * sigma_h * sigma_h sigma_v2 = 2.0 * sigma_v * sigma_v ! scalelength: approximately S ~ sigma * sqrt(8.0) for a Gaussian smoothing - if(myrank == 0 )print *," scalelengths horizontal,vertical (m): ",sigma_h*sqrt(8.0),sigma_v*sqrt(8.0) + if (myrank == 0 )print *," scalelengths horizontal,vertical (m): ",sigma_h*sqrt(8.0),sigma_v*sqrt(8.0) ! theoretic normal value ! (see integral over -inf to +inf of exp[- x*x/(2*sigma) ] = sigma * sqrt(2*pi) ) @@ -150,7 +150,7 @@ program random_model ! Gaussian function: values between [0,1] random(i,j,k,ispec) = exp( - (dist_h*dist_h) / sigma_h2 - (dist_v*dist_v) / sigma_v2 ) - !if(myrank == 0 )print *,random(i,j,k,ispec),x,y,z,dist_v,dist_h + !if (myrank == 0 )print *,random(i,j,k,ispec),x,y,z,dist_v,dist_h enddo enddo enddo diff --git a/EXAMPLES/BENCHMARK_CLAERBOUT_ADJOINT/ELASTIC/adj_seismogram.f90 b/EXAMPLES/BENCHMARK_CLAERBOUT_ADJOINT/ELASTIC/adj_seismogram.f90 index 469605add..ab7de18e0 100644 --- a/EXAMPLES/BENCHMARK_CLAERBOUT_ADJOINT/ELASTIC/adj_seismogram.f90 +++ b/EXAMPLES/BENCHMARK_CLAERBOUT_ADJOINT/ELASTIC/adj_seismogram.f90 @@ -22,7 +22,7 @@ program adj_seismogram write(procname,"(i4)") myrank !! input parameters - if( iargc() /= 2 ) stop 'Usage: ./xadj NSTEP DT' + if ( iargc() /= 2 ) stop 'Usage: ./xadj NSTEP DT' j=1; call getarg(j, arg); read(arg,*,iostat=ios) NSTEP; if (ios /= 0) stop 'Error reading NSTEP' j=2; call getarg(j, arg); read(arg,*,iostat=ios) DT; if (ios /= 0) stop 'Error reading DT' @@ -50,13 +50,13 @@ program adj_seismogram filename=trim(adjustl(procname))//"_dx_SU" open(111,file="../OUTPUT_FILES/SEM/syn/"//trim(filename), & status='old',access='direct',action='read',recl=240+4*NSTEP,iostat = ios) - if( ios /= 0 ) stop 'error opening file syn' + if ( ios /= 0 ) stop 'error opening file syn' open(112,file="../OUTPUT_FILES/SEM/dat/"//trim(filename), & status='old',access='direct',action='read',recl=240+4*NSTEP,iostat = ios) - if( ios /= 0 ) stop 'error opening file dat' + if ( ios /= 0 ) stop 'error opening file dat' open(113,file="../OUTPUT_FILES/SEM/"//trim(filename)//".adj", & status='unknown',access='direct',action='write',recl=240+4*NSTEP,iostat = ios) - if( ios /= 0 ) stop 'error opening file .adj' + if ( ios /= 0 ) stop 'error opening file .adj' irec=1 do while(ios==0) @@ -73,7 +73,7 @@ program adj_seismogram if (ios /= 0) exit !daniel: outputs ascii trace - if( myrank == 0 .and. irec == 196 ) then + if ( myrank == 0 .and. irec == 196 ) then open(221,file="../OUTPUT_FILES/SEM/syn/"//trim(filename)//".ascii",status='unknown') do i=1,NSTEP write(221,*) i,syn(i) @@ -101,13 +101,13 @@ program adj_seismogram filename=trim(adjustl(procname))//"_dy_SU" open(111,file="../OUTPUT_FILES/SEM/syn/"//trim(filename), & status='old',access='direct',action='read',recl=240+4*NSTEP,iostat = ios) - if( ios /= 0 ) stop 'error opening file syn' + if ( ios /= 0 ) stop 'error opening file syn' open(112,file="../OUTPUT_FILES/SEM/dat/"//trim(filename), & status='old',access='direct',action='read',recl=240+4*NSTEP,iostat = ios) - if( ios /= 0 ) stop 'error opening file dat' + if ( ios /= 0 ) stop 'error opening file dat' open(113,file="../OUTPUT_FILES/SEM/"//trim(filename)//".adj", & status='unknown',access='direct',action='write',recl=240+4*NSTEP,iostat = ios) - if( ios /= 0 ) stop 'error opening file .adj' + if ( ios /= 0 ) stop 'error opening file .adj' irec=1 do while(ios==0) @@ -123,7 +123,7 @@ program adj_seismogram if (ios /= 0) exit !daniel: outputs ascii trace - if( myrank == 0 .and. irec == 196 ) then + if ( myrank == 0 .and. irec == 196 ) then open(221,file="../OUTPUT_FILES/SEM/syn/"//trim(filename)//".ascii",status='unknown') do i=1,NSTEP write(221,*) i,syn(i) @@ -152,13 +152,13 @@ program adj_seismogram filename=trim(adjustl(procname))//"_dz_SU" open(111,file="../OUTPUT_FILES/SEM/syn/"//trim(filename), & status='old',access='direct',action='read',recl=240+4*NSTEP,iostat = ios) - if( ios /= 0 ) stop 'error opening file syn' + if ( ios /= 0 ) stop 'error opening file syn' open(112,file="../OUTPUT_FILES/SEM/dat/"//trim(filename), & status='old',access='direct',action='read',recl=240+4*NSTEP,iostat = ios) - if( ios /= 0 ) stop 'error opening file dat' + if ( ios /= 0 ) stop 'error opening file dat' open(113,file="../OUTPUT_FILES/SEM/"//trim(filename)//".adj", & status='unknown',access='direct',action='write',recl=240+4*NSTEP,iostat = ios) - if( ios /= 0 ) stop 'error opening file .adj' + if ( ios /= 0 ) stop 'error opening file .adj' irec=1 do while(ios==0) @@ -173,7 +173,7 @@ program adj_seismogram if (ios /= 0) exit !daniel: outputs ascii trace - if( myrank == 0 .and. irec == 196 ) then + if ( myrank == 0 .and. irec == 196 ) then open(221,file="../OUTPUT_FILES/SEM/syn/"//trim(filename)//".ascii",status='unknown') do i=1,NSTEP write(221,*) i,syn(i) diff --git a/EXAMPLES/BENCHMARK_CLAERBOUT_ADJOINT/ELASTIC/postprocessing.f90 b/EXAMPLES/BENCHMARK_CLAERBOUT_ADJOINT/ELASTIC/postprocessing.f90 index d49eae4bf..3ca51f506 100644 --- a/EXAMPLES/BENCHMARK_CLAERBOUT_ADJOINT/ELASTIC/postprocessing.f90 +++ b/EXAMPLES/BENCHMARK_CLAERBOUT_ADJOINT/ELASTIC/postprocessing.f90 @@ -14,7 +14,7 @@ program random_model real(kind=4),dimension(:), allocatable :: adj !! input parameters - if( iargc() /= 3 ) stop 'Usage: ./xpostprocessing NSTEP DT NPROC' + if ( iargc() /= 3 ) stop 'Usage: ./xpostprocessing NSTEP DT NPROC' j=1; call getarg(j, arg); read(arg,*,iostat=ios) NSTEP; if (ios /= 0) stop 'Error reading NSTEP' j=2; call getarg(j, arg); read(arg,*,iostat=ios) DT; if (ios /= 0) stop 'Error reading DT' j=3; call getarg(j, arg); read(arg,*,iostat=ios) NPROC; if (ios /= 0) stop 'Error reading NPROC' @@ -40,36 +40,36 @@ program random_model ! nspec & nglob open(unit=IOUT,file='./OUTPUT_FILES/DATABASES_MPI/'//trim(adjustl(prname))//'external_mesh.bin',status='old',action='read',form='unformatted',iostat=ier) - if( ier /= 0 ) stop 'error opening database proc######_external_mesh.bin' + if ( ier /= 0 ) stop 'error opening database proc######_external_mesh.bin' read(IOUT) nspec read(IOUT) nglob close(IOUT) ! weights - allocate(weights(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array weights' + allocate(weights(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array weights' open(unit=IOUT,file='./OUTPUT_FILES/DATABASES_MPI/'//trim(adjustl(prname))//'weights_kernel.bin',status='old',action='read',form='unformatted',iostat=ier) read(IOUT) weights close(IOUT) ! kernels - allocate(krhop(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array krhop' + allocate(krhop(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array krhop' open(unit=IOUT,file='./OUTPUT_FILES/DATABASES_MPI/'//trim(adjustl(prname))//'rhop_kernel.bin',status='old',action='read',form='unformatted',iostat=ier) read(IOUT) krhop close(IOUT) - allocate(kalpha(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array kalpha' + allocate(kalpha(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array kalpha' open(unit=IOUT,file='./OUTPUT_FILES/DATABASES_MPI/'//trim(adjustl(prname))//'alpha_kernel.bin',status='old',action='read',form='unformatted',iostat=ier) read(IOUT) kalpha close(IOUT) - allocate(kbeta(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array kbeta' + allocate(kbeta(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array kbeta' open(unit=IOUT,file='./OUTPUT_FILES/DATABASES_MPI/'//trim(adjustl(prname))//'beta_kernel.bin',status='old',action='read',form='unformatted',iostat=ier) read(IOUT) kbeta close(IOUT) ! rho - allocate(rho(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array rho' - allocate(rho0(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array rho0' + allocate(rho(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array rho' + allocate(rho0(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array rho0' open(unit=IOUT,file='./models/target_model/'//trim(adjustl(prname))//'rho.bin',status='old',action='read',form='unformatted') read(IOUT) rho close(IOUT) @@ -78,8 +78,8 @@ program random_model close(IOUT) ! vp - allocate(vp(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array vp' - allocate(vp0(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array vp0' + allocate(vp(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array vp' + allocate(vp0(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array vp0' open(unit=IOUT,file='./models/target_model/'//trim(adjustl(prname))//'vp.bin',status='old',action='read',form='unformatted') read(IOUT) vp close(IOUT) @@ -88,8 +88,8 @@ program random_model close(IOUT) ! vs - allocate(vs(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array vs' - allocate(vs0(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array vs0' + allocate(vs(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array vs' + allocate(vs0(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array vs0' open(unit=IOUT,file='./models/target_model/'//trim(adjustl(prname))//'vs.bin',status='old',action='read',form='unformatted') read(IOUT) vs close(IOUT) @@ -110,7 +110,7 @@ program random_model write(procname,"(i4)") myrank filename=trim(adjustl(procname))//"_dx_SU" open(111,file="./OUTPUT_FILES/SEM/"//trim(adjustl(filename))//".adj",access='direct',recl=240+4*NSTEP,iostat = ios) - if( ios /= 0 ) stop 'error opening adjoint trace' + if ( ios /= 0 ) stop 'error opening adjoint trace' print *,' ',trim(adjustl(filename))//".adj" irec=1 @@ -129,7 +129,7 @@ program random_model filename=trim(adjustl(procname))//"_dy_SU" open(111,file="./OUTPUT_FILES/SEM/"//trim(adjustl(filename))//".adj",access='direct',recl=240+4*NSTEP,iostat = ios) - if( ios /= 0 ) stop 'error opening adjoint trace' + if ( ios /= 0 ) stop 'error opening adjoint trace' print *,' ',trim(adjustl(filename))//".adj" irec=1 @@ -147,7 +147,7 @@ program random_model filename=trim(adjustl(procname))//"_dz_SU" open(111,file="./OUTPUT_FILES/SEM/"//trim(adjustl(filename))//".adj",access='direct',recl=240+4*NSTEP,iostat = ios) - if( ios /= 0 ) stop 'error opening adjoint trace' + if ( ios /= 0 ) stop 'error opening adjoint trace' print *,' ',trim(adjustl(filename))//".adj" irec=1 diff --git a/EXAMPLES/BENCHMARK_CLAERBOUT_ADJOINT/ELASTIC/random_model_generation.f90 b/EXAMPLES/BENCHMARK_CLAERBOUT_ADJOINT/ELASTIC/random_model_generation.f90 index 2f7969743..eff4aac7e 100644 --- a/EXAMPLES/BENCHMARK_CLAERBOUT_ADJOINT/ELASTIC/random_model_generation.f90 +++ b/EXAMPLES/BENCHMARK_CLAERBOUT_ADJOINT/ELASTIC/random_model_generation.f90 @@ -31,24 +31,24 @@ program random_model call MPI_Comm_Size(MPI_COMM_WORLD,NPROC,ier) !! input parameters - if( iargc() /= 1 ) stop 'Usage: ./xrandom_model percent [must be small enough (~1d-5) for F*dm=S(m+dm)-S(m) to be valid]' + if ( iargc() /= 1 ) stop 'Usage: ./xrandom_model percent [must be small enough (~1d-5) for F*dm=S(m+dm)-S(m) to be valid]' j=1; call getarg(j, arg); read(arg,*,iostat=ios) percent; if (ios /= 0) stop 'Error reading percent' ! processors name write(prname,'(a,i6.6,a)') trim(LOCAL_PATH)//'proc',myrank,'_' ! nspec & nglob open(unit=IOUT,file=trim(adjustl(prname))//'external_mesh.bin',status='old',action='read',form='unformatted',iostat=ier) - if( ier /= 0 ) stop 'error opening database proc######_external_mesh.bin' + if ( ier /= 0 ) stop 'error opening database proc######_external_mesh.bin' read(IOUT) nspec read(IOUT) nglob ! ibool file allocate(ibool(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) - if( ier /= 0 ) stop 'error allocating array ibool' + if ( ier /= 0 ) stop 'error allocating array ibool' read(IOUT) ibool ! global point arrays allocate(xstore(nglob),ystore(nglob),zstore(nglob),stat=ier) - if( ier /= 0 ) stop 'error allocating array xstore etc.' + if ( ier /= 0 ) stop 'error allocating array xstore etc.' read(IOUT) xstore read(IOUT) ystore read(IOUT) zstore @@ -56,18 +56,18 @@ program random_model close(IOUT) ! rho - allocate( rho_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array rho_read' + allocate( rho_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array rho_read' open(unit=IOUT,file=trim(adjustl(prname))//'rho.bin',status='old',action='read',form='unformatted') read(IOUT) rho_read close(IOUT) ! vp - allocate( vp_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array vp_read' + allocate( vp_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array vp_read' open(unit=IOUT,file=trim(adjustl(prname))//'vp.bin',status='old',action='read',form='unformatted') read(IOUT) vp_read close(IOUT) ! vs - allocate( vs_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array vs_read' + allocate( vs_read(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array vs_read' open(unit=IOUT,file=trim(adjustl(prname))//'vs.bin',status='old',action='read',form='unformatted') read(IOUT) vs_read close(IOUT) @@ -77,9 +77,9 @@ program random_model ! question: is the signal sensitive to this perturbation? or is it within numerical noise/artefacts? ! perturb model randomly - allocate( random(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if( ier /= 0 ) stop 'error allocating array random' + allocate( random(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if ( ier /= 0 ) stop 'error allocating array random' - if( .false. ) then + if ( .false. ) then CALL RANDOM_SEED() @@ -110,7 +110,7 @@ program random_model ! adds a Gaussian perturbation in the middle of the model - if( .true. ) then + if ( .true. ) then ! initializes perturbations random(:,:,:,:) = 0.0 @@ -122,7 +122,7 @@ program random_model sigma_h2 = 2.0 * sigma_h * sigma_h sigma_v2 = 2.0 * sigma_v * sigma_v ! scalelength: approximately S ~ sigma * sqrt(8.0) for a Gaussian smoothing - if(myrank == 0 )print *," scalelengths horizontal,vertical (m): ",sigma_h*sqrt(8.0),sigma_v*sqrt(8.0) + if (myrank == 0 )print *," scalelengths horizontal,vertical (m): ",sigma_h*sqrt(8.0),sigma_v*sqrt(8.0) ! theoretic normal value ! (see integral over -inf to +inf of exp[- x*x/(2*sigma) ] = sigma * sqrt(2*pi) ) @@ -150,7 +150,7 @@ program random_model ! Gaussian function: values between [0,1] random(i,j,k,ispec) = exp( - (dist_h*dist_h) / sigma_h2 - (dist_v*dist_v) / sigma_v2 ) - !if(myrank == 0 )print *,random(i,j,k,ispec),x,y,z,dist_v,dist_h + !if (myrank == 0 )print *,random(i,j,k,ispec),x,y,z,dist_v,dist_h enddo enddo enddo diff --git a/EXAMPLES/noise_tomography/adj_traveltime_filter.f90 b/EXAMPLES/noise_tomography/adj_traveltime_filter.f90 index 4542c325b..c6409e3a9 100644 --- a/EXAMPLES/noise_tomography/adj_traveltime_filter.f90 +++ b/EXAMPLES/noise_tomography/adj_traveltime_filter.f90 @@ -201,7 +201,7 @@ program adj_traveltime if (ier /= 0) stop 'Error opening misfit output file in SEM/' ! number of filter frequencies - if (filter_flag == 0) then + if (filter_flag == 0) then nfreq = 1 else nfreq = size(freq_low) @@ -367,7 +367,7 @@ end program adj_traveltime ! http://www-lgit.obs.ujf-grenoble.fr/users/jrevilla/seiscomp/patch/pack/plugins/seisan/LIB/bndpas.for -SUBROUTINE BNDPAS(F1,F2,DELT,D,G,N) +subroutine BNDPAS(F1,F2,DELT,D,G,N) ! RECURSIVE BUTTERWORTH BAND PASS FILTER (KANASEWICH, TIME SERIES ! ANALYSIS IN GEOPHYSICS, UNIVERSITY OF ALBERTA PRESS, 1975; SHANKS, ! JOHN L, RECURSION FILTERS FOR DIGITAL PROCESSING, GEOPHYSICS, V32, @@ -432,7 +432,7 @@ SUBROUTINE BNDPAS(F1,F2,DELT,D,G,N) ! IG = 1 one pass ! ig = 2 two passes - IF (ISW==1) GO TO 31 + if (ISW==1) goto 31 WRITE (6,6) 6 FORMAT ('1BNDPAS MUST BE CALLED BEFORE FILTER') return @@ -459,15 +459,15 @@ SUBROUTINE BNDPAS(F1,F2,DELT,D,G,N) XM1=XM XM=X(I) K=I-((I-1)/3)*3 - GO TO (34,35,36),K + goto (34,35,36),K 34 M=1 M1=3 M2=2 - GO TO 37 + goto 37 35 M=2 M1=1 M2=3 - GO TO 37 + goto 37 36 M=3 M1=2 M2=1 @@ -477,7 +477,7 @@ SUBROUTINE BNDPAS(F1,F2,DELT,D,G,N) 39 X(I)=XE(M)-XE(M2)-D(7)*X(I-1)-D(8)*X(I-2) ! ! - if(ig==1) goto 3333 + if (ig==1) goto 3333 XM2=X(N) XM1=X(N-1) XM=X(N-2) @@ -499,15 +499,15 @@ SUBROUTINE BNDPAS(F1,F2,DELT,D,G,N) J=N-I+1 XM=X(J) K=I-((I-1)/3)*3 - GO TO (44,45,46),K + goto (44,45,46),K 44 M=1 M1=3 M2=2 - GO TO 47 + goto 47 45 M=2 M1=1 M2=3 - GO TO 47 + goto 47 46 M=3 M1=2 M2=1 diff --git a/setup/config.h.in b/setup/config.h.in index e4c684d83..5b0983b2f 100644 --- a/setup/config.h.in +++ b/setup/config.h.in @@ -88,5 +88,5 @@ /* Uncomment and define to select optimized file i/o for regional simulations */ /* map fails when output files are > 4GB, which is often the case for GPU simulations */ -// #define USE_MAP_FUNCTION +// #define USE_MAP_function diff --git a/src/auxiliaries/detect_duplicates_stations_file.f90 b/src/auxiliaries/detect_duplicates_stations_file.f90 index 8eec7eb53..26ee69f59 100644 --- a/src/auxiliaries/detect_duplicates_stations_file.f90 +++ b/src/auxiliaries/detect_duplicates_stations_file.f90 @@ -39,7 +39,7 @@ program detect_duplicates_stations_file nrec = 0 do while(ios == 0) read(IIN,"(a)",iostat=ios) dummystring - if(ios == 0) nrec = nrec + 1 + if (ios == 0) nrec = nrec + 1 enddo close(IIN) @@ -67,10 +67,10 @@ program detect_duplicates_stations_file ! look for duplicates in the station file in terms of station name do irec = 1,nrec-1 - if(is_a_duplicate(irec)) cycle + if (is_a_duplicate(irec)) cycle do irec2 = irec+1,nrec - if(is_a_duplicate(irec2)) cycle - if(station_name(irec) == station_name(irec2) .and. network_name(irec) == network_name(irec2)) then + if (is_a_duplicate(irec2)) cycle + if (station_name(irec) == station_name(irec2) .and. network_name(irec) == network_name(irec2)) then print *, & network_name(irec2)(1:len_trim(network_name(irec2))),'.',station_name(irec2)(1:len_trim(station_name(irec2))), & ' is a duplicate of ',& @@ -85,10 +85,10 @@ program detect_duplicates_stations_file ! look for duplicates in the station file in terms of position do irec = 1,nrec-1 - if(is_a_duplicate(irec)) cycle + if (is_a_duplicate(irec)) cycle do irec2 = irec+1,nrec - if(is_a_duplicate(irec2)) cycle - if(stlat(irec) == stlat(irec2) .and. stlon(irec) == stlon(irec2)) then + if (is_a_duplicate(irec2)) cycle + if (stlat(irec) == stlat(irec2) .and. stlon(irec) == stlon(irec2)) then print *, & network_name(irec2)(1:len_trim(network_name(irec2))),'.',station_name(irec2)(1:len_trim(station_name(irec2))), & ' is a duplicate of ', & @@ -107,7 +107,7 @@ program detect_duplicates_stations_file open(unit=IOUT,file=STATIONS_FILE(1:len_trim(STATIONS_FILE))//'_cleaned',status='unknown',action='write') ! loop on all the stations to write station information do irec = 1,nrec - if(.not. is_a_duplicate(irec)) write(IOUT,*) trim(station_name(irec)),' ', & + if (.not. is_a_duplicate(irec)) write(IOUT,*) trim(station_name(irec)),' ', & trim(network_name(irec)),' ',sngl(stlat(irec)),' ',sngl(stlon(irec)),' ',sngl(stele(irec)),' ',sngl(stbur(irec)) enddo ! close receiver file diff --git a/src/check_mesh_quality/check_mesh_quality.f90 b/src/check_mesh_quality/check_mesh_quality.f90 index 9918106a6..036317932 100644 --- a/src/check_mesh_quality/check_mesh_quality.f90 +++ b/src/check_mesh_quality/check_mesh_quality.f90 @@ -101,7 +101,7 @@ program check_mesh_quality if (iformat /= 3) then - if(iformat == 1) then + if (iformat == 1) then ! ask the user to imput the range of skewness to use to select the elements print *,'enter skewness threshold (between 0. and 0.99) above which all elements will be displayed:' @@ -116,7 +116,7 @@ program check_mesh_quality if (threshold_AVS_DX_max < 0.d0) threshold_AVS_DX_max = 0.d0 if (threshold_AVS_DX_max > 0.99999d0) threshold_AVS_DX_max = 0.99999d0 - else if(iformat == 2) then + else if (iformat == 2) then print * print *,'1 = output elements ABOVE a certain element size' @@ -284,7 +284,7 @@ program check_mesh_quality print *,'done processing ',NSPEC,' elements out of ',NSPEC DISPLAY_HISTOGRAM_DISTMEAN = .true. - if(abs(max_of_distmean - min_of_distmean) < 1.d-3*distmean) then + if (abs(max_of_distmean - min_of_distmean) < 1.d-3*distmean) then print * print *,'Your input mesh seems to be perfect, i.e. all mean distances are equal;' print *,'Will thus not display any histogram of mean distance in the mesh, since it would lead to division by zero.' @@ -322,7 +322,7 @@ program check_mesh_quality ! print *,'min diagonal aspect ratio = ',diagonal_aspect_ratio_min print * - if(iformat == 2) then + if (iformat == 2) then if (iabove_or_below == 1) then ! output elements ABOVE a certain element size threshold_AVS_DX_min = threshold_AVS_DX_size_to_use @@ -358,7 +358,7 @@ program check_mesh_quality classes_of_histogram_skewness(iclass) = classes_of_histogram_skewness(iclass) + 1 ! store mean size in histogram - if(DISPLAY_HISTOGRAM_DISTMEAN) then + if (DISPLAY_HISTOGRAM_DISTMEAN) then iclass = int(((distmean - min_of_distmean) / (max_of_distmean - min_of_distmean)) * dble(NCLASS)) if (iclass < 0) iclass = 0 if (iclass > NCLASS-1) iclass = NCLASS-1 @@ -410,7 +410,7 @@ program check_mesh_quality !--------------------------------------------------------------- - if(DISPLAY_HISTOGRAM_DISTMEAN) then + if (DISPLAY_HISTOGRAM_DISTMEAN) then ! create histogram of mean distance and save it in a Gnuplot file print * @@ -443,7 +443,7 @@ program check_mesh_quality write(14,*) 'set term wxt' write(14,*) '#set term gif' - if(DISPLAY_HISTOGRAM_DISTMEAN) then + if (DISPLAY_HISTOGRAM_DISTMEAN) then write(14,*) '#set output "mesh_quality_histogram_meansize.gif"' write(14,*) 'set xrange [',sngl(min_of_distmean),':',sngl(max_of_distmean),']' write(14,*) 'set boxwidth ',sngl((max_of_distmean - min_of_distmean)/dble(NCLASS)) @@ -488,9 +488,9 @@ program check_mesh_quality call create_mesh_quality_data_3D(x,y,z,ibool,ispec,NSPEC,NGLOB,VP_MAX,delta_t, & equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,stability,distmin,distmax,distmean) - if(iformat == 1) then + if (iformat == 1) then value_to_use = equiangle_skewness - else if(iformat == 2) then + else if (iformat == 2) then value_to_use = distmean else stop 'error: incorrect value to use was entered' @@ -534,9 +534,9 @@ program check_mesh_quality call create_mesh_quality_data_3D(x,y,z,ibool,ispec,NSPEC,NGLOB,VP_MAX,delta_t, & equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,stability,distmin,distmax,distmean) - if(iformat == 1) then + if (iformat == 1) then value_to_use = equiangle_skewness - else if(iformat == 2) then + else if (iformat == 2) then value_to_use = distmean else stop 'error: incorrect value to use was entered' @@ -568,9 +568,9 @@ program check_mesh_quality call create_mesh_quality_data_3D(x,y,z,ibool,ispec,NSPEC,NGLOB,VP_MAX,delta_t, & equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,stability,distmin,distmax,distmean) - if(iformat == 1) then + if (iformat == 1) then value_to_use = equiangle_skewness - else if(iformat == 2) then + else if (iformat == 2) then value_to_use = distmean else stop 'error: incorrect value to use was entered' @@ -739,7 +739,7 @@ subroutine create_mesh_quality_data_3D(x,y,z,ibool,ispec,NSPEC,NGLOB,VP_MAX,delt norm_B = sqrt(vectorB_x**2 + vectorB_y**2 + vectorB_z**2) ! sanity check - if(norm_A <= ZERO .or. norm_B <= ZERO) then + if (norm_A <= ZERO .or. norm_B <= ZERO) then print *,'error detected in element ',ispec,' out of ',NSPEC print *,'error: negative of null norm found, norm_A, norm_B = ',norm_A, norm_B stop 'error in the norm found' @@ -749,7 +749,7 @@ subroutine create_mesh_quality_data_3D(x,y,z,ibool,ispec,NSPEC,NGLOB,VP_MAX,delt argument_of_arccos = (vectorA_x*vectorB_x + vectorA_y*vectorB_y + vectorA_z*vectorB_z) / (norm_A * norm_B) ! compute equiangle skewness - if(abs(argument_of_arccos) <= 0.9999999d0) then + if (abs(argument_of_arccos) <= 0.9999999d0) then angle_vectors = dacos(argument_of_arccos) equiangle_skewness = max(equiangle_skewness,dabs(2.d0 * angle_vectors - PI) / PI) else diff --git a/src/decompose_mesh/decompose_mesh.F90 b/src/decompose_mesh/decompose_mesh.F90 index bb8f5ec1c..0609b4153 100644 --- a/src/decompose_mesh/decompose_mesh.F90 +++ b/src/decompose_mesh/decompose_mesh.F90 @@ -824,7 +824,7 @@ subroutine check_valence() print *, 'node valence: min = ',minval(used_nodes_elmnts(:)),' max = ', maxval(used_nodes_elmnts(:)) - if(minval(used_nodes_elmnts(:)) <= 0) & + if (minval(used_nodes_elmnts(:)) <= 0) & stop 'Error: found some unused nodes (weird, but not necessarily fatal; your mesher may have created extra nodes).' ! max number of elements that contain the same node diff --git a/src/decompose_mesh/module_database.f90 b/src/decompose_mesh/module_database.f90 index f7520ff0e..5c6ee8d95 100644 --- a/src/decompose_mesh/module_database.f90 +++ b/src/decompose_mesh/module_database.f90 @@ -285,7 +285,7 @@ subroutine write_database(myrank, ipart, elmnts, nodes_coords, elmnts_glob, num enddo enddo endif !! on doit inclure ce if dessous ? - if (k > 0) then + if (k > 0) then ie_bnd_stored(inum_neigh_part) = ie_bnd_stored(inum_neigh_part) + 1 kE = ie_bnd_stored(inum_neigh_part) my_interfaces_ext_mesh(1,kE ,inum_neigh_part) = glob2loc_elmnt(iE) diff --git a/src/decompose_mesh/module_mesh.f90 b/src/decompose_mesh/module_mesh.f90 index 608f05248..45967f2b9 100644 --- a/src/decompose_mesh/module_mesh.f90 +++ b/src/decompose_mesh/module_mesh.f90 @@ -25,7 +25,6 @@ ! !===================================================================== - module module_mesh use shared_parameters @@ -759,7 +758,7 @@ end module module_mesh -!----------------------------- OTHERS SUBROUTINES ------------------------------------------------------- +!----------------------------- other subroutines ------------------------------------------------------- !-------------------------------------------------- ! loading : sets weights for acoustic/elastic/poroelastic elements to account for different diff --git a/src/decompose_mesh/module_qsort.f90 b/src/decompose_mesh/module_qsort.f90 index 154e845a2..65c8fcd69 100644 --- a/src/decompose_mesh/module_qsort.f90 +++ b/src/decompose_mesh/module_qsort.f90 @@ -50,7 +50,7 @@ recursive subroutine QsortC(A,Id) integer, intent(in out), dimension(:) :: Id integer :: iq - if(size(A) > 1) then + if (size(A) > 1) then call Partition(A, Id, iq) call QsortC(A(:iq-1), Id(:iq-1)) call QsortC(A(iq:), Id(iq:)) diff --git a/src/decompose_mesh/program_decompose_mesh_mpi.f90 b/src/decompose_mesh/program_decompose_mesh_mpi.f90 index b839f788a..eb21fb052 100644 --- a/src/decompose_mesh/program_decompose_mesh_mpi.f90 +++ b/src/decompose_mesh/program_decompose_mesh_mpi.f90 @@ -391,20 +391,16 @@ end subroutine send_partition_mesh_to_all ! !------------------------------------------------------- - - subroutine send_mesh_to_all(myrank) use module_mesh - integer, intent(in) :: myrank integer :: ier - if (myrank > 0) then allocate(elmnts_glob(NGNOD,nspec_glob),stat=ier) - if (ier /= 0)then + if (ier /= 0) then write(*,*) 'Error ', myrank, NGNOD,nspec_glob stop 'Error allocating array elmnts' endif diff --git a/src/decompose_mesh/scotch_5.1.12b/examples/scotch_example_2.f90 b/src/decompose_mesh/scotch_5.1.12b/examples/scotch_example_2.f90 index 3df26c0a1..dd71cf28a 100644 --- a/src/decompose_mesh/scotch_5.1.12b/examples/scotch_example_2.f90 +++ b/src/decompose_mesh/scotch_5.1.12b/examples/scotch_example_2.f90 @@ -5,7 +5,7 @@ !* AUTHOR : Francois PELLEGRINI ** !* Frederic COUDERC ** !* ** -!* FUNCTION : FORTRAN testbed for the LibSCOTCH ** +!* function : FORTRAN testbed for the LibSCOTCH ** !* library routines. ** !* ** !* DATES : # Version 5.1 : from : 24 jul 2010 ** diff --git a/src/generate_databases/create_regions_mesh.f90 b/src/generate_databases/create_regions_mesh.f90 index 1ffa47f99..e514e5fd2 100644 --- a/src/generate_databases/create_regions_mesh.f90 +++ b/src/generate_databases/create_regions_mesh.f90 @@ -25,7 +25,6 @@ ! !===================================================================== - subroutine create_regions_mesh() ! create the different regions of the mesh @@ -501,7 +500,7 @@ subroutine crm_ext_allocate_arrays(nspec,LOCAL_PATH,myrank, & num_free_surface_faces = nspec2D_top ! add bottom surface to free surface condition - if (BOTTOM_FREE_SURFACE) then + if (BOTTOM_FREE_SURFACE) then num_free_surface_faces = num_free_surface_faces + nspec2D_bottom if (STACEY_INSTEAD_OF_FREE_SURFACE) num_free_surface_faces = num_free_surface_faces - nspec2D_top endif diff --git a/src/generate_databases/generate_databases_adios_stubs.f90 b/src/generate_databases/generate_databases_adios_stubs.f90 index 31e58fbfd..57d598afd 100644 --- a/src/generate_databases/generate_databases_adios_stubs.f90 +++ b/src/generate_databases/generate_databases_adios_stubs.f90 @@ -35,7 +35,7 @@ !============================================================================== !--------------------------------------. -! Subroutines from model_gll_adios.F90 | +! subroutines from model_gll_adios.F90 | !--------------------------------------' subroutine model_gll_adios(myrank,nspec,LOCAL_PATH) @@ -58,7 +58,7 @@ subroutine model_gll_adios(myrank,nspec,LOCAL_PATH) end subroutine !----------------------------------------. -! Subroutines from model_ipati_adios.F90 | +! subroutines from model_ipati_adios.F90 | !----------------------------------------' module model_ipati_adios_mod @@ -126,7 +126,7 @@ end subroutine read_model_vp_rho_adios end module model_ipati_adios_mod !-------------------------------------------------. -! Subroutines from read_partition_files_adios.F90 | +! subroutines from read_partition_files_adios.F90 | !-------------------------------------------------' subroutine read_partition_files_adios() @@ -136,7 +136,7 @@ subroutine read_partition_files_adios() end subroutine read_partition_files_adios !-----------------------------------------------. -! Subroutines from save_arrays_solver_adios.F90 | +! subroutines from save_arrays_solver_adios.F90 | !-----------------------------------------------' subroutine save_arrays_solver_ext_mesh_adios(nspec, nglob, & @@ -180,7 +180,7 @@ subroutine save_arrays_solver_ext_mesh_adios(nspec, nglob, & end subroutine !--------------------------------------. -! Subroutines from save_moho_adios.F90 | +! subroutines from save_moho_adios.F90 | !--------------------------------------' subroutine crm_save_moho_adios() diff --git a/src/generate_databases/model_1d_prem.f90 b/src/generate_databases/model_1d_prem.f90 index e195fc4a9..f0229c7a0 100644 --- a/src/generate_databases/model_1d_prem.f90 +++ b/src/generate_databases/model_1d_prem.f90 @@ -368,7 +368,7 @@ subroutine model_1D_PREM_routine_PB(xloc,yloc,zloc,ro_prem,vp_prem,vs_prem,idom) ! else if (param=='v_s') then ! prem_sub=vs_prem*1000. ! else - ! write(6,*)'ERROR IN PREM_SUB FUNCTION:',param,'NOT AN OPTION' + ! write(6,*)'Error in PREM_SUB function:',param,' not an option' ! stop end subroutine model_1D_PREM_routine_PB diff --git a/src/generate_databases/model_salton_trough.f90 b/src/generate_databases/model_salton_trough.f90 index 29c7d795a..70fef5cf7 100644 --- a/src/generate_databases/model_salton_trough.f90 +++ b/src/generate_databases/model_salton_trough.f90 @@ -225,7 +225,7 @@ subroutine vx_xyz_interp(uc,vc,wc, vp, vs, rho) (v5 - GOCAD_ST_NO_DATA_VALUE) > eps .and. & (v6 - GOCAD_ST_NO_DATA_VALUE) > eps .and. & (v7 - GOCAD_ST_NO_DATA_VALUE) > eps .and. & - (v8 - GOCAD_ST_NO_DATA_VALUE) > eps) then + (v8 - GOCAD_ST_NO_DATA_VALUE) > eps) then vp = dble(v1 * (1-xi) * (1-eta) * (1-ga) +& v2 * xi * (1-eta) * (1-ga) +& v3 * xi * eta * (1-ga) +& @@ -262,7 +262,7 @@ subroutine vx_xyz_interp(uc,vc,wc, vp, vs, rho) zmesh = wc / (GOCAD_ST_NW - 1) * GOCAD_ST_W_Z + GOCAD_ST_O_Z ! vs - if (zmesh > -8500.) then + if (zmesh > -8500.) then vs = vp / (2 - (0.27*zmesh/(-8500))) else vs = vp/1.73 diff --git a/src/generate_databases/pml_set_local_dampingcoeff.f90 b/src/generate_databases/pml_set_local_dampingcoeff.f90 index eb5beedf4..1214e0835 100644 --- a/src/generate_databases/pml_set_local_dampingcoeff.f90 +++ b/src/generate_databases/pml_set_local_dampingcoeff.f90 @@ -1409,12 +1409,12 @@ subroutine pml_set_local_dampingcoeff(myrank,xstore,ystore,zstore) call max_all_all_cr(maximum_for_alphay,maximum_for_alphay_all) call max_all_all_cr(maximum_for_alphaz,maximum_for_alphaz_all) - if(minimum_for_dx_all < ZERO) stop "there is error in dx profile" - if(minimum_for_dy_all < ZERO) stop "there is error in dy profile" - if(minimum_for_dz_all < ZERO) stop "there is error in dz profile" - if(minimum_for_alphax_all < ZERO) stop "there is error in alphax profile" - if(minimum_for_alphay_all < ZERO) stop "there is error in alphay profile" - if(minimum_for_alphaz_all < ZERO) stop "there is error in alphaz profile" + if (minimum_for_dx_all < ZERO) stop "there is error in dx profile" + if (minimum_for_dy_all < ZERO) stop "there is error in dy profile" + if (minimum_for_dz_all < ZERO) stop "there is error in dz profile" + if (minimum_for_alphax_all < ZERO) stop "there is error in alphax profile" + if (minimum_for_alphay_all < ZERO) stop "there is error in alphay profile" + if (minimum_for_alphaz_all < ZERO) stop "there is error in alphaz profile" second_minimum_for_dx = HUGEVAL second_minimum_for_dy = HUGEVAL @@ -1429,47 +1429,47 @@ subroutine pml_set_local_dampingcoeff(myrank,xstore,ystore,zstore) do j = 1,NGLLY do i = 1,NGLLX iglob = ibool(i,j,k,ispec) - if(d_store_x(i,j,k,ispec_CPML) == minimum_for_dx_all .or. & + if (d_store_x(i,j,k,ispec_CPML) == minimum_for_dx_all .or. & xstore(iglob) == xoriginleft .or. xstore(iglob) == xoriginright) then - else if(second_minimum_for_dx >= d_store_x(i,j,k,ispec_CPML)) then + else if (second_minimum_for_dx >= d_store_x(i,j,k,ispec_CPML)) then second_minimum_for_dx = d_store_x(i,j,k,ispec_CPML) endif - if(d_store_y(i,j,k,ispec_CPML) == minimum_for_dy_all .or. & + if (d_store_y(i,j,k,ispec_CPML) == minimum_for_dy_all .or. & ystore(iglob) == yoriginfront .or. ystore(iglob) == yoriginback) then - else if(second_minimum_for_dy >= d_store_y(i,j,k,ispec_CPML)) then + else if (second_minimum_for_dy >= d_store_y(i,j,k,ispec_CPML)) then second_minimum_for_dy = d_store_y(i,j,k,ispec_CPML) endif if (PML_INSTEAD_OF_FREE_SURFACE) then - if(d_store_z(i,j,k,ispec_CPML) == minimum_for_dz_all .or. & + if (d_store_z(i,j,k,ispec_CPML) == minimum_for_dz_all .or. & zstore(iglob) == zorigintop .or. zstore(iglob) == zoriginbottom) then - else if(second_minimum_for_dz >= d_store_z(i,j,k,ispec_CPML)) then + else if (second_minimum_for_dz >= d_store_z(i,j,k,ispec_CPML)) then second_minimum_for_dz = d_store_z(i,j,k,ispec_CPML) endif else - if(d_store_z(i,j,k,ispec_CPML) == minimum_for_dz_all .or. & + if (d_store_z(i,j,k,ispec_CPML) == minimum_for_dz_all .or. & zstore(iglob) == zoriginbottom) then - else if(second_minimum_for_dz >= d_store_z(i,j,k,ispec_CPML)) then + else if (second_minimum_for_dz >= d_store_z(i,j,k,ispec_CPML)) then second_minimum_for_dz = d_store_z(i,j,k,ispec_CPML) endif endif - if(alpha_store_x(i,j,k,ispec_CPML) == minimum_for_alphax_all .or. & + if (alpha_store_x(i,j,k,ispec_CPML) == minimum_for_alphax_all .or. & xstore(iglob) == x_max_all .or. xstore(iglob) == x_min_all) then - else if(second_minimum_for_alphax >= alpha_store_x(i,j,k,ispec_CPML)) then + else if (second_minimum_for_alphax >= alpha_store_x(i,j,k,ispec_CPML)) then second_minimum_for_alphax = alpha_store_x(i,j,k,ispec_CPML) endif - if(alpha_store_y(i,j,k,ispec_CPML) == minimum_for_alphay_all .or. & + if (alpha_store_y(i,j,k,ispec_CPML) == minimum_for_alphay_all .or. & ystore(iglob) == y_max_all .or. ystore(iglob) == y_min_all) then - else if(second_minimum_for_alphay >= alpha_store_y(i,j,k,ispec_CPML)) then + else if (second_minimum_for_alphay >= alpha_store_y(i,j,k,ispec_CPML)) then second_minimum_for_alphay = alpha_store_y(i,j,k,ispec_CPML) endif - if(alpha_store_z(i,j,k,ispec_CPML) == minimum_for_alphaz_all .or. & + if (alpha_store_z(i,j,k,ispec_CPML) == minimum_for_alphaz_all .or. & zstore(iglob) == z_max_all .or. zstore(iglob) == z_min_all) then - else if(second_minimum_for_alphaz >= alpha_store_z(i,j,k,ispec_CPML)) then + else if (second_minimum_for_alphaz >= alpha_store_z(i,j,k,ispec_CPML)) then second_minimum_for_alphaz = alpha_store_z(i,j,k,ispec_CPML) endif @@ -1492,17 +1492,17 @@ subroutine pml_set_local_dampingcoeff(myrank,xstore,ystore,zstore) call min_all_all_cr(second_minimum_for_alphay,second_minimum_for_alphay_all) call min_all_all_cr(second_minimum_for_alphaz,second_minimum_for_alphaz_all) - if(second_minimum_for_dx_all < minimum_for_dx_all) & + if (second_minimum_for_dx_all < minimum_for_dx_all) & stop "there is error in dectection of second_minimum_for_dx_all in dx profile" - if(second_minimum_for_dy_all < minimum_for_dy_all) & + if (second_minimum_for_dy_all < minimum_for_dy_all) & stop "there is error in dectection of second_minimum_for_dy_all in dy profile" - if(second_minimum_for_dz_all < minimum_for_dz_all) & + if (second_minimum_for_dz_all < minimum_for_dz_all) & stop "there is error in dectection of second_minimum_for_dz_all in dz profile" - if(second_minimum_for_alphax_all < minimum_for_alphax_all) & + if (second_minimum_for_alphax_all < minimum_for_alphax_all) & stop "there is error in dectection of second_minimum_for_alphax_all in alphax profile" - if(second_minimum_for_alphay_all < minimum_for_alphay_all) & + if (second_minimum_for_alphay_all < minimum_for_alphay_all) & stop "there is error in dectection of second_minimum_for_alphay_all in alphay profile" - if(second_minimum_for_alphaz_all < minimum_for_alphaz_all) & + if (second_minimum_for_alphaz_all < minimum_for_alphaz_all) & stop "there is error in dectection of second_minimum_for_alphaz_all in alphaz profile" second_minimum_for_alpha_all = min(second_minimum_for_alphax_all,second_minimum_for_alphay_all,& @@ -1670,7 +1670,7 @@ subroutine pml_set_local_dampingcoeff(myrank,xstore,ystore,zstore) d_store_z(i,j,k,ispec_CPML) = d_z alpha_store_z(i,j,k,ispec_CPML) = alpha_z - else if(CPML_regions(ispec_CPML) == CPML_XYZ) then + else if (CPML_regions(ispec_CPML) == CPML_XYZ) then K_x = K_store_x(i,j,k,ispec_CPML) d_x = d_store_x(i,j,k,ispec_CPML) @@ -1685,20 +1685,20 @@ subroutine pml_set_local_dampingcoeff(myrank,xstore,ystore,zstore) alpha_z = alpha_store_z(i,j,k,ispec_CPML) if (abs(alpha_x - alpha_y) < min_distance_between_CPML_parameter) then - if(alpha_x > alpha_y)then + if (alpha_x > alpha_y) then alpha_x = alpha_y + const_for_separation_two else alpha_y = alpha_x + const_for_separation_two endif maxtemp = max(alpha_x, alpha_y) mintemp = min(alpha_x, alpha_y) - if(alpha_z > maxtemp)then - if(abs(alpha_z - maxtemp) < min_distance_between_CPML_parameter)then + if (alpha_z > maxtemp) then + if (abs(alpha_z - maxtemp) < min_distance_between_CPML_parameter) then alpha_z = maxtemp + const_for_separation_two endif - else if(alpha_z < mintemp)then - if(abs(alpha_z - mintemp) < min_distance_between_CPML_parameter)then - if(alpha_x > alpha_y)then + else if (alpha_z < mintemp) then + if (abs(alpha_z - mintemp) < min_distance_between_CPML_parameter) then + if (alpha_x > alpha_y) then alpha_x = alpha_z + const_for_separation_four alpha_y = alpha_z + const_for_separation_two else @@ -1707,7 +1707,7 @@ subroutine pml_set_local_dampingcoeff(myrank,xstore,ystore,zstore) endif endif else - if(alpha_x > alpha_y)then + if (alpha_x > alpha_y) then alpha_x = alpha_y + const_for_separation_four alpha_z = alpha_y + const_for_separation_two else @@ -1718,20 +1718,20 @@ subroutine pml_set_local_dampingcoeff(myrank,xstore,ystore,zstore) endif if (abs(alpha_x - alpha_z) < min_distance_between_CPML_parameter) then - if(alpha_x > alpha_z)then + if (alpha_x > alpha_z) then alpha_x = alpha_z + const_for_separation_two else alpha_z = alpha_x + const_for_separation_two endif maxtemp = max(alpha_x, alpha_z) mintemp = min(alpha_x, alpha_z) - if(alpha_y > maxtemp)then - if(abs(alpha_y - maxtemp) < min_distance_between_CPML_parameter)then + if (alpha_y > maxtemp) then + if (abs(alpha_y - maxtemp) < min_distance_between_CPML_parameter) then alpha_y = maxtemp + const_for_separation_two endif - else if(alpha_y < mintemp)then - if(abs(alpha_y - mintemp) < min_distance_between_CPML_parameter)then - if(alpha_x > alpha_z)then + else if (alpha_y < mintemp) then + if (abs(alpha_y - mintemp) < min_distance_between_CPML_parameter) then + if (alpha_x > alpha_z) then alpha_x = alpha_y + const_for_separation_four alpha_z = alpha_y + const_for_separation_two else @@ -1740,7 +1740,7 @@ subroutine pml_set_local_dampingcoeff(myrank,xstore,ystore,zstore) endif endif else - if(alpha_x > alpha_z)then + if (alpha_x > alpha_z) then alpha_x = alpha_z + const_for_separation_four alpha_y = alpha_z + const_for_separation_two else @@ -1751,20 +1751,20 @@ subroutine pml_set_local_dampingcoeff(myrank,xstore,ystore,zstore) endif if (abs(alpha_y - alpha_z) < min_distance_between_CPML_parameter) then - if(alpha_y > alpha_z)then + if (alpha_y > alpha_z) then alpha_y = alpha_z + const_for_separation_two else alpha_z = alpha_y + const_for_separation_two endif maxtemp = max(alpha_y, alpha_z) mintemp = min(alpha_y, alpha_z) - if(alpha_x > maxtemp)then - if(abs(alpha_x - maxtemp) < min_distance_between_CPML_parameter)then + if (alpha_x > maxtemp) then + if (abs(alpha_x - maxtemp) < min_distance_between_CPML_parameter) then alpha_x = maxtemp + const_for_separation_two endif - else if(alpha_x < mintemp)then - if(abs(alpha_x - mintemp) < min_distance_between_CPML_parameter)then - if(alpha_y > alpha_z)then + else if (alpha_x < mintemp) then + if (abs(alpha_x - mintemp) < min_distance_between_CPML_parameter) then + if (alpha_y > alpha_z) then alpha_y = alpha_x + const_for_separation_four alpha_z = alpha_x + const_for_separation_two else @@ -1773,7 +1773,7 @@ subroutine pml_set_local_dampingcoeff(myrank,xstore,ystore,zstore) endif endif else - if(alpha_y > alpha_z)then + if (alpha_y > alpha_z) then alpha_y = alpha_z + const_for_separation_four alpha_x = alpha_z + const_for_separation_two else @@ -1792,20 +1792,20 @@ subroutine pml_set_local_dampingcoeff(myrank,xstore,ystore,zstore) beta_x = alpha_x + d_x / K_x maxtemp = max(alpha_y, alpha_z) mintemp = min(alpha_y, alpha_z) - if(beta_x > maxtemp)then - if(abs(beta_x- maxtemp) < min_distance_between_CPML_parameter)then + if (beta_x > maxtemp) then + if (abs(beta_x- maxtemp) < min_distance_between_CPML_parameter) then beta_x = maxtemp + const_for_separation_two endif - else if(beta_x < mintemp)then - if(abs(beta_x - mintemp) < min_distance_between_CPML_parameter)then - if(alpha_y > alpha_z)then + else if (beta_x < mintemp) then + if (abs(beta_x - mintemp) < min_distance_between_CPML_parameter) then + if (alpha_y > alpha_z) then beta_x = alpha_y + const_for_separation_two else beta_x = alpha_z + const_for_separation_two endif endif else - if(alpha_y > alpha_z)then + if (alpha_y > alpha_z) then beta_x = alpha_y + const_for_separation_two else beta_x = alpha_z + const_for_separation_two @@ -1816,20 +1816,20 @@ subroutine pml_set_local_dampingcoeff(myrank,xstore,ystore,zstore) maxtemp = max(alpha_x, alpha_z) mintemp = min(alpha_x, alpha_z) - if(beta_y > maxtemp)then - if(abs(beta_y - maxtemp) < min_distance_between_CPML_parameter)then + if (beta_y > maxtemp) then + if (abs(beta_y - maxtemp) < min_distance_between_CPML_parameter) then beta_y = maxtemp + const_for_separation_two endif - else if(beta_y < mintemp)then - if(abs(beta_y - mintemp) < min_distance_between_CPML_parameter)then - if(alpha_x > alpha_z)then + else if (beta_y < mintemp) then + if (abs(beta_y - mintemp) < min_distance_between_CPML_parameter) then + if (alpha_x > alpha_z) then beta_y = alpha_x + const_for_separation_two else beta_y = alpha_z + const_for_separation_two endif endif else - if(alpha_x > alpha_z)then + if (alpha_x > alpha_z) then beta_y = alpha_x + const_for_separation_two else beta_y = alpha_z + const_for_separation_two @@ -1839,20 +1839,20 @@ subroutine pml_set_local_dampingcoeff(myrank,xstore,ystore,zstore) beta_z = alpha_z + d_z / K_z maxtemp = max(alpha_x, alpha_y) mintemp = min(alpha_x, alpha_y) - if(beta_z > maxtemp)then - if(abs(beta_z - maxtemp) < min_distance_between_CPML_parameter)then + if (beta_z > maxtemp) then + if (abs(beta_z - maxtemp) < min_distance_between_CPML_parameter) then beta_z = maxtemp + const_for_separation_two endif - else if(beta_z < mintemp)then - if(abs(beta_z - mintemp) < min_distance_between_CPML_parameter)then - if(alpha_x > alpha_y)then + else if (beta_z < mintemp) then + if (abs(beta_z - mintemp) < min_distance_between_CPML_parameter) then + if (alpha_x > alpha_y) then beta_z = alpha_x + const_for_separation_two else beta_z = alpha_y + const_for_separation_two endif endif else - if(alpha_x > alpha_y)then + if (alpha_x > alpha_y) then beta_z = alpha_x + const_for_separation_two else beta_z = alpha_y + const_for_separation_two @@ -2019,7 +2019,7 @@ function pml_damping_profile_l(myrank,iglob,dist,vp,delta) ! In INRIA research report section 6.1: http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf ! pml_damping_profile_l = - ((NPOWER + 1) * vp * log(CPML_Rcoef) / (TWO * delta)) * dist**(NPOWER) ! based on tests it is more accurate to use the following definition when NPOWER = 1 as defined in constants.h.in - if(CUSTOM_REAL == SIZE_REAL) then + if (CUSTOM_REAL == SIZE_REAL) then pml_damping_profile_l = - sngl(((NPOWER + 1.d0) * dble(vp) * log(CPML_Rcoef) / & (TWO * dble(delta))) * dble(dist)**(1.2d0 * NPOWER)) else @@ -2045,7 +2045,7 @@ subroutine seperate_two_changeable_value(value_a,value_b,const_for_separation_tw implicit none real(kind=CUSTOM_REAL), intent(in) :: const_for_separation_two real(kind=CUSTOM_REAL) :: value_a,value_b - if(value_a >= value_b) then + if (value_a >= value_b) then value_a = value_b + const_for_separation_two else value_b = value_a + const_for_separation_two diff --git a/src/generate_databases/setup_color_perm.f90 b/src/generate_databases/setup_color_perm.f90 index 710a3eb91..503601009 100644 --- a/src/generate_databases/setup_color_perm.f90 +++ b/src/generate_databases/setup_color_perm.f90 @@ -25,7 +25,6 @@ ! !===================================================================== - subroutine setup_color_perm(myrank,nspec,nglob,ibool,ANISOTROPY,SAVE_MESH_FILES) ! sets up mesh coloring and permutes elements @@ -602,7 +601,7 @@ subroutine setup_permutation(myrank,nspec,nglob,ibool,ANISOTROPY,perm,SAVE_MESH_ call permute_elements_real(kappastore,temp_array_real,perm,nspec) call permute_elements_real(mustore,temp_array_real,perm,nspec) - if(ATTENUATION) then + if (ATTENUATION) then call permute_elements_real(qmu_attenuation_store,temp_array_real,perm,nspec) call permute_elements_real(qkappa_attenuation_store,temp_array_real,perm,nspec) endif diff --git a/src/meshfem3D/check_mesh_quality.f90 b/src/meshfem3D/check_mesh_quality.f90 index 310323a1c..8255654bb 100644 --- a/src/meshfem3D/check_mesh_quality.f90 +++ b/src/meshfem3D/check_mesh_quality.f90 @@ -537,7 +537,7 @@ subroutine create_mesh_quality_data_3D(x,y,z,ibool,ispec,NSPEC,NGLOB,VP_MAX,dt_s argument_of_arccos = (vectorA_x*vectorB_x + vectorA_y*vectorB_y + vectorA_z*vectorB_z) / (norm_A * norm_B) ! compute equiangle skewness - if(abs(argument_of_arccos) <= 0.9999999d0) then + if (abs(argument_of_arccos) <= 0.9999999d0) then angle_vectors = dacos(argument_of_arccos) equiangle_skewness = max(equiangle_skewness,dabs(2.d0 * angle_vectors - PI) / PI) else diff --git a/src/meshfem3D/create_CPML_regions.f90 b/src/meshfem3D/create_CPML_regions.f90 index bed3cb955..eb7e65b32 100644 --- a/src/meshfem3D/create_CPML_regions.f90 +++ b/src/meshfem3D/create_CPML_regions.f90 @@ -119,7 +119,7 @@ subroutine create_CPML_regions(nspec,nglob,nodes_coords) ! Xmin CPML limit=xmin_all+THICKNESS_OF_X_PML * SMALL_PERCENTAGE_TOLERANCE - if( nodes_coords(i1,1) < limit .and. nodes_coords(i2,1) < limit .and. & + if ( nodes_coords(i1,1) < limit .and. nodes_coords(i2,1) < limit .and. & nodes_coords(i3,1) < limit .and. nodes_coords(i4,1) < limit .and. & nodes_coords(i5,1) < limit .and. nodes_coords(i6,1) < limit .and. & nodes_coords(i7,1) < limit .and. nodes_coords(i8,1) < limit) then @@ -128,7 +128,7 @@ subroutine create_CPML_regions(nspec,nglob,nodes_coords) ! Xmax CPML limit = xmax_all - THICKNESS_OF_X_PML * SMALL_PERCENTAGE_TOLERANCE - if( nodes_coords(i1,1) > limit .and. nodes_coords(i2,1) > limit .and. & + if ( nodes_coords(i1,1) > limit .and. nodes_coords(i2,1) > limit .and. & nodes_coords(i3,1) > limit .and. nodes_coords(i4,1) > limit .and. & nodes_coords(i5,1) > limit .and. nodes_coords(i6,1) > limit .and. & nodes_coords(i7,1) > limit .and. nodes_coords(i8,1) > limit) then @@ -137,7 +137,7 @@ subroutine create_CPML_regions(nspec,nglob,nodes_coords) ! Ymin CPML limit=ymin_all+THICKNESS_OF_Y_PML * SMALL_PERCENTAGE_TOLERANCE - if( nodes_coords(i1,2) < limit .and. nodes_coords(i2,2) < limit .and. & + if ( nodes_coords(i1,2) < limit .and. nodes_coords(i2,2) < limit .and. & nodes_coords(i3,2) < limit .and. nodes_coords(i4,2) < limit .and. & nodes_coords(i5,2) < limit .and. nodes_coords(i6,2) < limit .and. & nodes_coords(i7,2) < limit .and. nodes_coords(i8,2) < limit) then @@ -146,7 +146,7 @@ subroutine create_CPML_regions(nspec,nglob,nodes_coords) ! Ymax CPML limit = ymax_all - THICKNESS_OF_Y_PML * SMALL_PERCENTAGE_TOLERANCE - if( nodes_coords(i1,2) > limit .and. nodes_coords(i2,2) > limit .and. & + if ( nodes_coords(i1,2) > limit .and. nodes_coords(i2,2) > limit .and. & nodes_coords(i3,2) > limit .and. nodes_coords(i4,2) > limit .and. & nodes_coords(i5,2) > limit .and. nodes_coords(i6,2) > limit .and. & nodes_coords(i7,2) > limit .and. nodes_coords(i8,2) > limit) then @@ -155,17 +155,17 @@ subroutine create_CPML_regions(nspec,nglob,nodes_coords) ! Zmin CPML limit=zmin_all+THICKNESS_OF_Z_PML * SMALL_PERCENTAGE_TOLERANCE - if( nodes_coords(i1,3) < limit .and. nodes_coords(i2,3) < limit .and. & + if ( nodes_coords(i1,3) < limit .and. nodes_coords(i2,3) < limit .and. & nodes_coords(i3,3) < limit .and. nodes_coords(i4,3) < limit .and. & nodes_coords(i5,3) < limit .and. nodes_coords(i6,3) < limit .and. & nodes_coords(i7,3) < limit .and. nodes_coords(i8,3) < limit) then is_Z_CPML(ispec) = .true. endif - if(PML_INSTEAD_OF_FREE_SURFACE) then + if (PML_INSTEAD_OF_FREE_SURFACE) then ! Zmax CPML limit = zmax_all - THICKNESS_OF_Z_PML * SMALL_PERCENTAGE_TOLERANCE - if( nodes_coords(i1,3) > limit .and. nodes_coords(i2,3) > limit .and. & + if ( nodes_coords(i1,3) > limit .and. nodes_coords(i2,3) > limit .and. & nodes_coords(i3,3) > limit .and. nodes_coords(i4,3) > limit .and. & nodes_coords(i5,3) > limit .and. nodes_coords(i6,3) > limit .and. & nodes_coords(i7,3) > limit .and. nodes_coords(i8,3) > limit) then @@ -173,7 +173,7 @@ subroutine create_CPML_regions(nspec,nglob,nodes_coords) endif endif - if(is_X_CPML(ispec) .or. is_Y_CPML(ispec) .or. is_Z_CPML(ispec)) & + if (is_X_CPML(ispec) .or. is_Y_CPML(ispec) .or. is_Z_CPML(ispec)) & nspec_CPML = nspec_CPML + 1 enddo @@ -197,42 +197,42 @@ subroutine create_CPML_regions(nspec,nglob,nodes_coords) ispec_CPML=0 do ispec=1,nspec - if(is_X_CPML(ispec) .and. is_Y_CPML(ispec) .and. is_Z_CPML(ispec)) then + if (is_X_CPML(ispec) .and. is_Y_CPML(ispec) .and. is_Z_CPML(ispec)) then ispec_CPML=ispec_CPML+1 CPML_to_spec(ispec_CPML)=ispec CPML_regions(ispec_CPML)=CPML_XYZ is_CPML(ispec)=.true. - else if(is_Y_CPML(ispec) .and. is_Z_CPML(ispec)) then + else if (is_Y_CPML(ispec) .and. is_Z_CPML(ispec)) then ispec_CPML=ispec_CPML+1 CPML_to_spec(ispec_CPML)=ispec CPML_regions(ispec_CPML)=CPML_YZ_ONLY is_CPML(ispec)=.true. - else if(is_X_CPML(ispec) .and. is_Z_CPML(ispec)) then + else if (is_X_CPML(ispec) .and. is_Z_CPML(ispec)) then ispec_CPML=ispec_CPML+1 CPML_to_spec(ispec_CPML)=ispec CPML_regions(ispec_CPML)=CPML_XZ_ONLY is_CPML(ispec)=.true. - else if(is_X_CPML(ispec) .and. is_Y_CPML(ispec)) then + else if (is_X_CPML(ispec) .and. is_Y_CPML(ispec)) then ispec_CPML=ispec_CPML+1 CPML_to_spec(ispec_CPML)=ispec CPML_regions(ispec_CPML)=CPML_XY_ONLY is_CPML(ispec)=.true. - else if(is_Z_CPML(ispec)) then + else if (is_Z_CPML(ispec)) then ispec_CPML=ispec_CPML+1 CPML_to_spec(ispec_CPML)=ispec CPML_regions(ispec_CPML)=CPML_Z_ONLY is_CPML(ispec)=.true. - else if(is_Y_CPML(ispec)) then + else if (is_Y_CPML(ispec)) then ispec_CPML=ispec_CPML+1 CPML_to_spec(ispec_CPML)=ispec CPML_regions(ispec_CPML)=CPML_Y_ONLY is_CPML(ispec)=.true. - else if(is_X_CPML(ispec)) then + else if (is_X_CPML(ispec)) then ispec_CPML=ispec_CPML+1 CPML_to_spec(ispec_CPML)=ispec CPML_regions(ispec_CPML)=CPML_X_ONLY @@ -243,6 +243,6 @@ subroutine create_CPML_regions(nspec,nglob,nodes_coords) enddo ! checks - if(ispec_CPML /= nspec_CPML) stop 'Error number of CPML element is not consistent' + if (ispec_CPML /= nspec_CPML) stop 'Error number of CPML element is not consistent' end subroutine create_CPML_regions diff --git a/src/meshfem3D/create_meshfem_mesh.f90 b/src/meshfem3D/create_meshfem_mesh.f90 index 2ab72f1d2..1fb5dfdcd 100644 --- a/src/meshfem3D/create_meshfem_mesh.f90 +++ b/src/meshfem3D/create_meshfem_mesh.f90 @@ -630,9 +630,9 @@ subroutine create_meshfem_mesh() ymid = 0.5d0*(y0+y1) zmid = 0.5d0*(z0+z1) - if((xmid>=cavity_x0 .and. xmid<=cavity_x1) .and. & + if ((xmid>=cavity_x0 .and. xmid<=cavity_x1) .and. & (ymid>=cavity_y0 .and. ymid<=cavity_y1) .and. & - (zmid>=cavity_z0 .and. zmid<=cavity_z1))then + (zmid>=cavity_z0 .and. zmid<=cavity_z1)) then ! deactivate spectral element iselmt(i_spec)=.false. else @@ -658,24 +658,24 @@ subroutine create_meshfem_mesh() ispec = 0 do i_spec = 1,nspec_old - if(iselmt(i_spec))then + if (iselmt(i_spec)) then ispec = ispec + 1 ispec_new(i_spec) = ispec endif enddo - if(ispec /= nspec) call exit_MPI(myrank,'ERROR: new number of spectral elements mismatch!') + if (ispec /= nspec) call exit_MPI(myrank,'ERROR: new number of spectral elements mismatch!') allocate(inode_new(nglob_old)) inode_new(:) = -1 inode = 0 do i_node = 1,nglob_old - if(isnode(i_node))then + if (isnode(i_node)) then inode = inode + 1 inode_new(i_node) = inode endif enddo - if(inode/=nglob)call exit_MPI(myrank,'ERROR: new number of spectral elements mismatch!') + if (inode/=nglob)call exit_MPI(myrank,'ERROR: new number of spectral elements mismatch!') allocate(nodes_coords_old(nglob_old,3)) allocate(ispec_material_id_old(nspec_old)) @@ -704,7 +704,7 @@ subroutine create_meshfem_mesh() ! new specs do i_spec=1,nspec_old - if(iselmt(i_spec))then + if (iselmt(i_spec)) then ispec_material_id(ispec_new(i_spec))=ispec_material_id_old(i_spec) iboun(:,ispec_new(i_spec))=iboun_old(:,i_spec) iMPIcut_xi(:,ispec_new(i_spec))=iMPIcut_xi_old(:,i_spec) @@ -723,7 +723,7 @@ subroutine create_meshfem_mesh() ! new coordinates do i_node=1,nglob_old - if(isnode(i_node))then + if (isnode(i_node)) then nodes_coords(inode_new(i_node),:)=nodes_coords_old(i_node,:) endif enddo diff --git a/src/meshfem3D/meshfem3D.F90 b/src/meshfem3D/meshfem3D.F90 index 6cd52faf9..2b5ed13fb 100644 --- a/src/meshfem3D/meshfem3D.F90 +++ b/src/meshfem3D/meshfem3D.F90 @@ -479,7 +479,7 @@ subroutine meshfem3D() else write(IMAIN,*) 'using UTM projection in region ',UTM_PROJECTION_ZONE endif - if(PML_CONDITIONS) then + if (PML_CONDITIONS) then write(IMAIN,*) write(IMAIN,*) 'PML thickness in X direction = ',THICKNESS_OF_X_PML,'m' write(IMAIN,*) 'PML thickness in Y direction = ',THICKNESS_OF_Y_PML,'m' diff --git a/src/meshfem3D/save_databases.F90 b/src/meshfem3D/save_databases.F90 index 61fce4d4e..f52e2e6f3 100644 --- a/src/meshfem3D/save_databases.F90 +++ b/src/meshfem3D/save_databases.F90 @@ -259,7 +259,7 @@ subroutine save_databases(prname,nspec,nglob,iproc_xi,iproc_eta, & call synchronize_all() write(IIN_database) nspec_CPML_total - if(nspec_CPML_total > 0) then + if (nspec_CPML_total > 0) then write(IIN_database) nspec_CPML do ispec_CPML=1,nspec_CPML write(IIN_database) CPML_to_spec(ispec_CPML), CPML_regions(ispec_CPML) @@ -361,7 +361,7 @@ subroutine save_databases(prname,nspec,nglob,iproc_xi,iproc_eta, & if (interfaces(NW)) then write(IIN_database) addressing(iproc_xi-1,iproc_eta+1),nspec_interface(NW) do ispec = 1,nspec - if ((iMPIcut_xi(1,ispec) .eqv. .true.) .and. (iMPIcut_eta(2,ispec) .eqv. .true.)) then + if ((iMPIcut_xi(1,ispec) .eqv. .true.) .and. (iMPIcut_eta(2,ispec) .eqv. .true.)) then write(IIN_database) ispec,2,ibool(1,2,1,ispec),ibool(1,2,2,ispec),-1,-1 endif enddo @@ -370,7 +370,7 @@ subroutine save_databases(prname,nspec,nglob,iproc_xi,iproc_eta, & if (interfaces(NE)) then write(IIN_database) addressing(iproc_xi+1,iproc_eta+1),nspec_interface(NE) do ispec = 1,nspec - if ((iMPIcut_xi(2,ispec) .eqv. .true.) .and. (iMPIcut_eta(2,ispec) .eqv. .true.)) then + if ((iMPIcut_xi(2,ispec) .eqv. .true.) .and. (iMPIcut_eta(2,ispec) .eqv. .true.)) then write(IIN_database) ispec,2,ibool(2,2,1,ispec),ibool(2,2,2,ispec),-1,-1 endif enddo @@ -379,7 +379,7 @@ subroutine save_databases(prname,nspec,nglob,iproc_xi,iproc_eta, & if (interfaces(SE)) then write(IIN_database) addressing(iproc_xi+1,iproc_eta-1),nspec_interface(SE) do ispec = 1,nspec - if ((iMPIcut_xi(2,ispec) .eqv. .true.) .and. (iMPIcut_eta(1,ispec) .eqv. .true.)) then + if ((iMPIcut_xi(2,ispec) .eqv. .true.) .and. (iMPIcut_eta(1,ispec) .eqv. .true.)) then write(IIN_database) ispec,2,ibool(2,1,1,ispec),ibool(2,1,2,ispec),-1,-1 endif enddo @@ -388,7 +388,7 @@ subroutine save_databases(prname,nspec,nglob,iproc_xi,iproc_eta, & if (interfaces(SW)) then write(IIN_database) addressing(iproc_xi-1,iproc_eta-1),nspec_interface(SW) do ispec = 1,nspec - if ((iMPIcut_xi(1,ispec) .eqv. .true.) .and. (iMPIcut_eta(1,ispec) .eqv. .true.)) then + if ((iMPIcut_xi(1,ispec) .eqv. .true.) .and. (iMPIcut_eta(1,ispec) .eqv. .true.)) then write(IIN_database) ispec,2,ibool(1,1,1,ispec),ibool(1,1,2,ispec),-1,-1 endif enddo diff --git a/src/meshfem3D/save_databases_adios.F90 b/src/meshfem3D/save_databases_adios.F90 index 9e14b5ce1..46495df1e 100644 --- a/src/meshfem3D/save_databases_adios.F90 +++ b/src/meshfem3D/save_databases_adios.F90 @@ -475,7 +475,7 @@ subroutine save_databases_adios(LOCAL_PATH, myrank, sizeprocs, & ispec_interface = 1 do ispec = 1,nspec if ((iMPIcut_xi(1,ispec) .eqv. .true.) & - .and. (iMPIcut_eta(2,ispec) .eqv. .true.)) then + .and. (iMPIcut_eta(2,ispec) .eqv. .true.)) then interfaces_mesh(1, ispec_interface, interface_num) = ispec interfaces_mesh(2, ispec_interface, interface_num) = 2 interfaces_mesh(3, ispec_interface, interface_num) & @@ -496,7 +496,7 @@ subroutine save_databases_adios(LOCAL_PATH, myrank, sizeprocs, & ispec_interface = 1 do ispec = 1,nspec if ((iMPIcut_xi(2,ispec) .eqv. .true.) & - .and. (iMPIcut_eta(2,ispec) .eqv. .true.)) then + .and. (iMPIcut_eta(2,ispec) .eqv. .true.)) then interfaces_mesh(1, ispec_interface, interface_num) = ispec interfaces_mesh(2, ispec_interface, interface_num) = 2 interfaces_mesh(3, ispec_interface, interface_num) & @@ -517,7 +517,7 @@ subroutine save_databases_adios(LOCAL_PATH, myrank, sizeprocs, & ispec_interface = 1 do ispec = 1,nspec if ((iMPIcut_xi(2,ispec) .eqv. .true.) & - .and. (iMPIcut_eta(1,ispec) .eqv. .true.)) then + .and. (iMPIcut_eta(1,ispec) .eqv. .true.)) then interfaces_mesh(1, ispec_interface, interface_num) = ispec interfaces_mesh(2, ispec_interface, interface_num) = 2 interfaces_mesh(3, ispec_interface, interface_num) & @@ -538,7 +538,7 @@ subroutine save_databases_adios(LOCAL_PATH, myrank, sizeprocs, & ispec_interface = 1 do ispec = 1,nspec if ((iMPIcut_xi(1,ispec) .eqv. .true.) & - .and. (iMPIcut_eta(1,ispec) .eqv. .true.)) then + .and. (iMPIcut_eta(1,ispec) .eqv. .true.)) then interfaces_mesh(1, ispec_interface, interface_num) = ispec interfaces_mesh(2, ispec_interface, interface_num) = 2 interfaces_mesh(3, ispec_interface, interface_num) & @@ -625,7 +625,7 @@ subroutine save_databases_adios(LOCAL_PATH, myrank, sizeprocs, & call define_adios_scalar(group, groupsize, "", STRINGIFY_VAR(nspec2d_top)) call define_adios_scalar(group, groupsize, "", "nspec_cpml_total",nspec_cpml_total) - if(nspec_cpml_total>0) call define_adios_scalar(group, groupsize, "", "nspec_cpml",nspec_cpml) + if (nspec_cpml_total>0) call define_adios_scalar(group, groupsize, "", "nspec_cpml",nspec_cpml) call define_adios_scalar(group, groupsize, "", STRINGIFY_VAR(nb_interfaces)) call define_adios_scalar(group, groupsize, "", STRINGIFY_VAR(nspec_interfaces_max)) @@ -678,7 +678,7 @@ subroutine save_databases_adios(LOCAL_PATH, myrank, sizeprocs, & local_dim = NGNOD2D * nspec2d_top_wmax call define_adios_global_array1D(group, groupsize, local_dim, "", STRINGIFY_VAR(nodes_ibelm_top)) - if(nspec_CPML_total > 0) then + if (nspec_CPML_total > 0) then local_dim=nspec_CPML call define_adios_global_array1D(group, groupsize, local_dim, "", STRINGIFY_VAR(CPML_to_spec)) call define_adios_global_array1D(group, groupsize, local_dim, "", STRINGIFY_VAR(CPML_regions)) @@ -729,7 +729,7 @@ subroutine save_databases_adios(LOCAL_PATH, myrank, sizeprocs, & call adios_write(handle, STRINGIFY_VAR(nspec2d_top), ier) call adios_write(handle, "nspec_cpml_total", nspec_cpml_total, ier) - if(nspec_CPML_total > 0) call adios_write(handle, "nspec_cpml", nspec_cpml, ier) + if (nspec_CPML_total > 0) call adios_write(handle, "nspec_cpml", nspec_cpml, ier) call adios_write(handle, STRINGIFY_VAR(nb_interfaces), ier) call adios_write(handle, STRINGIFY_VAR(nspec_interfaces_max), ier) @@ -823,7 +823,7 @@ subroutine save_databases_adios(LOCAL_PATH, myrank, sizeprocs, & endif ! CPML - if(nspec_CPML_total > 0) then + if (nspec_CPML_total > 0) then local_dim=nspec_CPML call write_adios_global_1d_array(handle, myrank, sizeprocs, local_dim, & STRINGIFY_VAR(CPML_to_spec)) diff --git a/src/shared/get_attenuation_model.f90 b/src/shared/get_attenuation_model.f90 index 72624d7e5..460e3794c 100644 --- a/src/shared/get_attenuation_model.f90 +++ b/src/shared/get_attenuation_model.f90 @@ -1225,7 +1225,7 @@ subroutine fminsearch(funk, x, n, itercount, tolf, prnt, err) ! 4 => report every iteration, total simplex ! err = Output ! 0 => Normal exeecution, converged within desired range -! 1 => Function Evaluation exceeded limit +! 1 => function evaluation exceeded limit ! 2 => Iterations exceeded limit ! ! See Matlab fminsearch diff --git a/src/shared/gll_library.f90 b/src/shared/gll_library.f90 index 1a8d99322..bbd95e026 100644 --- a/src/shared/gll_library.f90 +++ b/src/shared/gll_library.f90 @@ -333,7 +333,7 @@ end subroutine jacobf !------------------------------------------------------------------------ ! - double precision FUNCTION PNDLEG (Z,N) + double precision function PNDLEG (Z,N) !------------------------------------------------------------------------ ! @@ -373,7 +373,7 @@ end function pndleg !------------------------------------------------------------------------ ! - double precision FUNCTION PNLEG (Z,N) + double precision function PNLEG (Z,N) !------------------------------------------------------------------------ ! diff --git a/src/shared/netlib_specfun_erf.f90 b/src/shared/netlib_specfun_erf.f90 index 4247002f1..8bd990291 100644 --- a/src/shared/netlib_specfun_erf.f90 +++ b/src/shared/netlib_specfun_erf.f90 @@ -39,8 +39,8 @@ subroutine calerf(ARG,RESULT,jintval) !------------------------------------------------------------------ ! ! This packet evaluates erf(x) for a real argument x. -! It contains one FUNCTION type subprogram: ERF, -! and one SUBROUTINE type subprogram, CALERF. The calling +! It contains one function type subprogram: ERF, +! and one subroutine type subprogram, CALERF. The calling ! statements for the primary entries are: ! ! Y = ERF(X) @@ -54,7 +54,7 @@ subroutine calerf(ARG,RESULT,jintval) ! ! where the parameter usage is as follows ! -! Function Parameters for CALERF +! function Parameters for CALERF ! call ARG Result jintval ! ! ERF(ARG) ANY REAL ARGUMENT ERF(ARG) 0 diff --git a/src/shared/parallel.f90 b/src/shared/parallel.f90 index b34713689..b856b9d32 100644 --- a/src/shared/parallel.f90 +++ b/src/shared/parallel.f90 @@ -153,7 +153,7 @@ subroutine abort_mpi() call MPI_COMM_RANK(MPI_COMM_WORLD,my_global_rank,ier) ! write a stamp file to disk to let the user know that the run failed - if(NUMBER_OF_SIMULTANEOUS_RUNS > 1) then + if (NUMBER_OF_SIMULTANEOUS_RUNS > 1) then ! notifies which run directory failed write(filename,"('run',i4.4,'_failed')") mygroup + 1 inquire(file=trim(filename), exist=run_file_exists) @@ -184,7 +184,7 @@ subroutine abort_mpi() ! in case of a large number of simultaneous runs, if one fails we may want that one to just call MPI_FINALIZE() and wait ! until all the others are finished instead of calling MPI_ABORT(), which would instead kill all the runs, ! including all the successful ones - if(USE_FAILSAFE_MECHANISM .and. NUMBER_OF_SIMULTANEOUS_RUNS > 1) then + if (USE_FAILSAFE_MECHANISM .and. NUMBER_OF_SIMULTANEOUS_RUNS > 1) then ! do NOT remove the barrier here, it is critical in order to let other runs finish before calling MPI_FINALIZE call MPI_BARRIER(MPI_COMM_WORLD,ier) call MPI_FINALIZE(ier) diff --git a/src/shared/read_parameter_file.F90 b/src/shared/read_parameter_file.F90 index 34a0589af..da38ce211 100644 --- a/src/shared/read_parameter_file.F90 +++ b/src/shared/read_parameter_file.F90 @@ -56,7 +56,7 @@ subroutine read_parameter_file(myrank,BROADCAST_AFTER_READ) ! read from a single processor (the master) and then use MPI to broadcast to others ! to avoid an I/O bottleneck in the case of very large runs - if(myrank == 0) then + if (myrank == 0) then ! opens file Par_file call open_parameter_file(ier) @@ -430,11 +430,11 @@ subroutine read_parameter_file(myrank,BROADCAST_AFTER_READ) stop 'Error for IPATI model, please set USE_RICKER_TIME_FUNCTION to .true. in Par_file and recompile solver' endif - endif ! of if(myrank == 0) then + endif ! of if (myrank == 0) then ! read from a single processor (the master) and then use MPI to broadcast to others ! to avoid an I/O bottleneck in the case of very large runs - if(BROADCAST_AFTER_READ) then + if (BROADCAST_AFTER_READ) then call bcast_all_singlei_world(NPROC) call bcast_all_singlei_world(SIMULATION_TYPE) @@ -516,7 +516,7 @@ subroutine read_parameter_file(myrank,BROADCAST_AFTER_READ) call bcast_all_string_world(FORCESOLUTION) call bcast_all_string_world(CMTSOLUTION) - endif ! of if(BROADCAST_AFTER_READ) then + endif ! of if (BROADCAST_AFTER_READ) then end subroutine read_parameter_file diff --git a/src/specfem3D/calendar.f90 b/src/specfem3D/calendar.f90 index 09757f1bf..e9562bae7 100644 --- a/src/specfem3D/calendar.f90 +++ b/src/specfem3D/calendar.f90 @@ -129,7 +129,7 @@ subroutine calndr(iday,month,iyear,idayct) !---------- ! -! Subroutine calndr() performs calendar calculations using either +! subroutine calndr() performs calendar calculations using either ! the standard Gregorian calendar or the old Julian calendar. ! This subroutine extends the definitions of these calendar systems ! to any arbitrary year. The algorithms in this subroutine @@ -143,7 +143,7 @@ subroutine calndr(iday,month,iyear,idayct) ! !---------- ! -! INPUT/OUTPUT ARGUMENTS FOR SUBROUTINE CALNDR() +! Input/output arguments for subroutine CALNDR() ! ! "ioptn" is the desired calendar conversion option explained below. ! Positive option values use the standard modern Gregorian calendar. @@ -159,7 +159,7 @@ subroutine calndr(iday,month,iyear,idayct) ! For BC years, iyear should be negative, so 45 BC would be iyear=-45. ! By convention, there is no year 0 under the BC/AD year numbering ! scheme. That is, years proceed as 2 BC, 1 BC, 1 AD, 2 AD, etc., -! without including 0. Subroutine calndr() will print an error message +! without including 0. The subroutine calndr() will print an error message ! and stop if you specify iyear = 0. ! ! "idayct" is a day count. It is either the day number during the diff --git a/src/specfem3D/compute_add_sources_acoustic.f90 b/src/specfem3D/compute_add_sources_acoustic.f90 index 1e19ed902..bd70e7ee2 100644 --- a/src/specfem3D/compute_add_sources_acoustic.f90 +++ b/src/specfem3D/compute_add_sources_acoustic.f90 @@ -711,7 +711,7 @@ double precision function get_stf_acoustic(time_source_dble,isource) ! Newmark time scheme acceleration is accurate at zeroth order while displacement is accurate at second order, ! thus in fluid elements potential_dot_dot_acoustic() is accurate at zeroth order while potential_acoustic() ! is accurate at second order and thus contains significantly less numerical noise. - if(USE_TRICK_FOR_BETTER_PRESSURE) then + if (USE_TRICK_FOR_BETTER_PRESSURE) then stf = comp_source_time_function_d2rck(time_source_dble,hdur(isource)) else stf = comp_source_time_function_rickr(time_source_dble,hdur(isource)) @@ -726,7 +726,7 @@ double precision function get_stf_acoustic(time_source_dble,isource) ! Newmark time scheme acceleration is accurate at zeroth order while displacement is accurate at second order, ! thus in fluid elements potential_dot_dot_acoustic() is accurate at zeroth order while potential_acoustic() ! is accurate at second order and thus contains significantly less numerical noise. - if(USE_TRICK_FOR_BETTER_PRESSURE) then + if (USE_TRICK_FOR_BETTER_PRESSURE) then stf = comp_source_time_function_d2gau(time_source_dble,5.d0*DT) else stf = comp_source_time_function_gauss(time_source_dble,5.d0*DT) @@ -744,7 +744,7 @@ double precision function get_stf_acoustic(time_source_dble,isource) ! Newmark time scheme acceleration is accurate at zeroth order while displacement is accurate at second order, ! thus in fluid elements potential_dot_dot_acoustic() is accurate at zeroth order while potential_acoustic() ! is accurate at second order and thus contains significantly less numerical noise. - if(USE_TRICK_FOR_BETTER_PRESSURE) then + if (USE_TRICK_FOR_BETTER_PRESSURE) then stf = comp_source_time_function_d2rck(time_source_dble,hdur(isource)) else stf = comp_source_time_function_rickr(time_source_dble,hdur(isource)) @@ -758,7 +758,7 @@ double precision function get_stf_acoustic(time_source_dble,isource) ! Newmark time scheme acceleration is accurate at zeroth order while displacement is accurate at second order, ! thus in fluid elements potential_dot_dot_acoustic() is accurate at zeroth order while potential_acoustic() ! is accurate at second order and thus contains significantly less numerical noise. - if(USE_TRICK_FOR_BETTER_PRESSURE) then + if (USE_TRICK_FOR_BETTER_PRESSURE) then stf = comp_source_time_function_d2gau(time_source_dble,hdur_Gaussian(isource)) else stf = comp_source_time_function_gauss(time_source_dble,hdur_Gaussian(isource)) @@ -769,7 +769,7 @@ double precision function get_stf_acoustic(time_source_dble,isource) ! stf = comp_source_time_function(time_source_dble,hdur_Gaussian(isource)) ! source encoding - if(USE_SOURCE_ENCODING) stf = stf * pm1_source_encoding(isource) + if (USE_SOURCE_ENCODING) stf = stf * pm1_source_encoding(isource) endif ! USE_FORCE_POINT_SOURCE diff --git a/src/specfem3D/compute_add_sources_viscoelastic.F90 b/src/specfem3D/compute_add_sources_viscoelastic.F90 index 89266abe6..5fe8000aa 100644 --- a/src/specfem3D/compute_add_sources_viscoelastic.F90 +++ b/src/specfem3D/compute_add_sources_viscoelastic.F90 @@ -846,7 +846,7 @@ double precision function get_stf_viscoelastic(time_source_dble,isource) ! source encoding ! not supported yet for viscoelastic elements... sign of moment-tensor needs to be determined prior to running simulation - !if(USE_SOURCE_ENCODING) stf = stf * pm1_source_encoding(isource) + !if (USE_SOURCE_ENCODING) stf = stf * pm1_source_encoding(isource) endif ! USE_FORCE_POINT_SOURCE diff --git a/src/specfem3D/compute_forces_acoustic_calling_routine.f90 b/src/specfem3D/compute_forces_acoustic_calling_routine.f90 index 67aabc3c5..5dc4b1683 100644 --- a/src/specfem3D/compute_forces_acoustic_calling_routine.f90 +++ b/src/specfem3D/compute_forces_acoustic_calling_routine.f90 @@ -143,7 +143,7 @@ subroutine compute_forces_acoustic() endif ! poroelastic coupling - if (POROELASTIC_SIMULATION ) then + if (POROELASTIC_SIMULATION) then if (num_coupling_ac_po_faces > 0) then if (SIMULATION_TYPE == 1) then call compute_coupling_acoustic_po(NSPEC_AB,NGLOB_AB, & @@ -391,7 +391,7 @@ subroutine compute_forces_acoustic_backward() endif ! poroelastic coupling - if (POROELASTIC_SIMULATION ) then + if (POROELASTIC_SIMULATION) then if (num_coupling_ac_po_faces > 0) then stop 'coupling acoustic-poroelastic domains not implemented yet...' endif @@ -516,7 +516,7 @@ subroutine compute_forces_acoustic_GPU() endif ! poroelastic coupling - if (POROELASTIC_SIMULATION ) then + if (POROELASTIC_SIMULATION) then if (num_coupling_ac_po_faces > 0) then if (SIMULATION_TYPE == 1) then call compute_coupling_acoustic_po(NSPEC_AB,NGLOB_AB, & diff --git a/src/specfem3D/compute_forces_viscoelastic_calling_routine.F90 b/src/specfem3D/compute_forces_viscoelastic_calling_routine.F90 index 80d049c08..c331e42ba 100644 --- a/src/specfem3D/compute_forces_viscoelastic_calling_routine.F90 +++ b/src/specfem3D/compute_forces_viscoelastic_calling_routine.F90 @@ -677,13 +677,7 @@ subroutine compute_forces_viscoelastic_GPU() ! request_send_vector_ext_mesh,request_recv_vector_ext_mesh, & ! 1) - - - if((mod(it,500)==0) .and. (it /= 0)) call synchronize_GPU(it) ! output results every 500 steps - - - - + if (mod(it,500) == 0 .and. it /= 0) call synchronize_GPU(it) ! output results every 500 steps ! transfers acceleration back to GPU ! call transfer_accel_to_device(NDIM*NGLOB_AB,accel, Mesh_pointer) diff --git a/src/specfem3D/compute_forces_viscoelastic_noDev.f90 b/src/specfem3D/compute_forces_viscoelastic_noDev.f90 index 5df00fe18..c98a650ac 100644 --- a/src/specfem3D/compute_forces_viscoelastic_noDev.f90 +++ b/src/specfem3D/compute_forces_viscoelastic_noDev.f90 @@ -1168,7 +1168,7 @@ end subroutine compute_forces_viscoelastic_noDev ! The concept of parent element can be found in ! O.C.Zienkiewicz, R.L.Taylor & J.Z. Zhu, The finite element method its basis and fundamentals 6th ed., ! Elsevier Press (2005) ! pages 141 -Subroutine compute_strain_in_parent_element(tempx1_att,tempx2_att,tempx3_att,tempx1,tempx2,tempx3,& +subroutine compute_strain_in_parent_element(tempx1_att,tempx2_att,tempx3_att,tempx1,tempx2,tempx3,& tempy1_att,tempy2_att,tempy3_att,tempy1,tempy2,tempy3,& tempz1_att,tempz2_att,tempz3_att,tempz1,tempz2,tempz3,& dummyx_loc,dummyy_loc,dummyz_loc,hprime_xx,hprime_yy,hprime_zz) diff --git a/src/specfem3D/compute_interpolated_dva.f90 b/src/specfem3D/compute_interpolated_dva.f90 index 9703a8103..c865bd8e2 100644 --- a/src/specfem3D/compute_interpolated_dva.f90 +++ b/src/specfem3D/compute_interpolated_dva.f90 @@ -25,7 +25,6 @@ ! !===================================================================== - subroutine compute_interpolated_dva(displ,veloc,accel,NGLOB_AB, & ispec,NSPEC_AB,ibool, & xi_r,eta_r,gamma_r, & @@ -196,7 +195,7 @@ subroutine compute_interpolated_dva_acoust(displ_element,veloc_element,accel_ele iglob = ibool(nint(xi_r),nint(eta_r),nint(gamma_r),ispec) ! pressure - if(USE_TRICK_FOR_BETTER_PRESSURE) then + if (USE_TRICK_FOR_BETTER_PRESSURE) then ! use a trick to increase accuracy of pressure seismograms in fluid (acoustic) elements: ! use the second derivative of the source for the source time function instead of the source itself, ! and then record -potential_acoustic() as pressure seismograms instead of -potential_dot_dot_acoustic(); @@ -251,7 +250,7 @@ subroutine compute_interpolated_dva_acoust(displ_element,veloc_element,accel_ele iglob = ibool(i,j,k,ispec) ! pressure - if(USE_TRICK_FOR_BETTER_PRESSURE) then + if (USE_TRICK_FOR_BETTER_PRESSURE) then ! use a trick to increase accuracy of pressure seismograms in fluid (acoustic) elements: ! use the second derivative of the source for the source time function instead of the source itself, ! and then record -potential_acoustic() as pressure seismograms instead of -potential_dot_dot_acoustic(); diff --git a/src/specfem3D/compute_kernels.f90 b/src/specfem3D/compute_kernels.f90 index 4f2315c59..cb01616a2 100644 --- a/src/specfem3D/compute_kernels.f90 +++ b/src/specfem3D/compute_kernels.f90 @@ -444,7 +444,7 @@ end subroutine compute_kernels_hessian !------------------------------------------------------------------------------------------------- ! -! Subroutine to compute the kernels for the 21 elastic coefficients +! subroutine to compute the kernels for the 21 elastic coefficients ! Last modified 19/04/2007 !------------------------------------------------------------------- diff --git a/src/specfem3D/fault_solver_dynamic.f90 b/src/specfem3D/fault_solver_dynamic.f90 index 9a051ee15..d61f83831 100644 --- a/src/specfem3D/fault_solver_dynamic.f90 +++ b/src/specfem3D/fault_solver_dynamic.f90 @@ -156,7 +156,7 @@ subroutine BC_DYNFLT_init(prname,DTglobal,myrank) allocate( faults(nbfaults) ) dt = real(DTglobal) read(IIN_PAR,nml=RUPTURE_SWITCHES,end=110,iostat=ier) - if(ier/=0) write(*,*) 'RUPTURE_SWITCHES not found in Par_file_faults' + if (ier/=0) write(*,*) 'RUPTURE_SWITCHES not found in Par_file_faults' do iflt=1,nbfaults read(IIN_PAR,nml=BEGIN_FAULT,end=100) call init_one_fault(faults(iflt),IIN_BIN,IIN_PAR,dt,nt,iflt,myrank) @@ -255,7 +255,7 @@ subroutine init_one_fault(bc,IIN_BIN,IIN_PAR,dt,NT,iflt,myrank) bc%T0(2,:) = S2 bc%T0(3,:) = S3 - if(LOAD_STRESSDROP) then + if (LOAD_STRESSDROP) then call make_frictional_stress call load_stress_drop endif @@ -371,7 +371,7 @@ subroutine make_frictional_stress bc%T0(1,:)=T1tmp bc%T0(2,:)=T2tmp - end subroutine make_frictional_stress + end subroutine make_frictional_stress !-------- @@ -896,7 +896,7 @@ subroutine rsf_GPU_init() call transfer_todevice_rsf_data(Fault_pointer,faults(ifault)%nglob,ifault-1 & ,f%V0,f%f0,f%V_init,f%a,f%b,f%L,f%theta,f%T,f%C,f%fw,f%Vw) ! ifault - 1 because in C language, array index start from 0 - else if(associated(g)) then + else if (associated(g)) then ! slip weakening friction simulation call transfer_todevice_swf_data(Fault_pointer,faults(ifault)%nglob,ifault-1 & ,g%Dc,g%mus,g%mud,g%T,g%C,g%theta) @@ -1009,7 +1009,7 @@ subroutine rsf_init(f,T0,V,nucFload,coord,IIN_PAR) ! WARNING: The line below scratches an earlier initialization of theta through theta_init ! We should implement it as an option for the user - if(TPV16) then + if (TPV16) then if (f%stateLaw == 1) then f%theta = f%L/f%V0 & * exp( ( f%a * log(TWO*sinh(-sqrt(T0(1,:)**2+T0(2,:)**2)/T0(3,:)/f%a)) & @@ -1706,7 +1706,7 @@ subroutine synchronize_GPU(it) call gather_dataXZ(faults(ifault)) call SCEC_write_dataT(faults(ifault)%dataT) - if(myrank == 0 )call write_dataXZ(faults(ifault)%dataXZ_all,it,ifault) + if (myrank == 0 )call write_dataXZ(faults(ifault)%dataXZ_all,it,ifault) enddo diff --git a/src/specfem3D/fault_solver_kinematic.f90 b/src/specfem3D/fault_solver_kinematic.f90 index f7de3e320..c33bb7f10 100644 --- a/src/specfem3D/fault_solver_kinematic.f90 +++ b/src/specfem3D/fault_solver_kinematic.f90 @@ -313,27 +313,22 @@ end subroutine BC_KINFLT_set_single subroutine init_dataXZ(dataXZ,bc) - type(dataXZ_type), intent(inout) :: dataXZ type(bc_dynandkinflt_type) :: bc - - - if(bc%nglob > 0) then - - - dataXZ%d1 => bc%d(1,:) - dataXZ%d2 => bc%d(2,:) - dataXZ%v1 => bc%v(1,:) - dataXZ%v2 => bc%v(2,:) - dataXZ%t1 => bc%t(1,:) - dataXZ%t2 => bc%t(2,:) - dataXZ%t3 => bc%t(3,:) - allocate(dataXZ%xcoord(bc%nglob)) - allocate(dataXZ%ycoord(bc%nglob)) - allocate(dataXZ%zcoord(bc%nglob)) -! + if (bc%nglob > 0) then + dataXZ%d1 => bc%d(1,:) + dataXZ%d2 => bc%d(2,:) + dataXZ%v1 => bc%v(1,:) + dataXZ%v2 => bc%v(2,:) + dataXZ%t1 => bc%t(1,:) + dataXZ%t2 => bc%t(2,:) + dataXZ%t3 => bc%t(3,:) + allocate(dataXZ%xcoord(bc%nglob)) + allocate(dataXZ%ycoord(bc%nglob)) + allocate(dataXZ%zcoord(bc%nglob)) endif + end subroutine init_dataXZ !=============================================================== @@ -397,9 +392,9 @@ subroutine load_vslip_snapshots(dataXZ,itime,iflt,myrank) ! COMPILERS WRITE BINARY OUTPUTS IN DIFFERENT FORMATS !!!!!!!!!! ! open(unit=IIN_BIN, file= trim(filename), status='old', form='unformatted',& ! action='read',iostat=ier) -! if( ier /= 0 ) stop 'Snapshots have been found' +! if ( ier /= 0 ) stop 'Snapshots have been found' - if(ier == 0) then + if (ier == 0) then ! read(IIN_BIN,"(5F24.15)") dataXZ%xcoord,dataXZ%ycoord,dataXZ%zcoord,dataXZ%v1,dataXZ%v2 write(IMAIN,*) 'Load vslip file for kinematic rupture simulation!' ! write(IMAIN,*) max(abs(dataXZ diff --git a/src/specfem3D/get_cmt.f90 b/src/specfem3D/get_cmt.f90 index 67b64180f..adbc8ea52 100644 --- a/src/specfem3D/get_cmt.f90 +++ b/src/specfem3D/get_cmt.f90 @@ -319,7 +319,7 @@ subroutine get_cmt(yr,jda,ho,mi,sec,tshift_cmt,hdur,lat,long,depth,moment_tensor if (hdur(isource) < 5. * DT) hdur(isource) = 5. * DT ! reads USER EXTERNAL SOURCE if needed - if (EXTERNAL_STF) then + if (EXTERNAL_STF) then ! gets external STF file name read(IIN,"(a)") string external_stf_filename = trim(string) diff --git a/src/specfem3D/iterate_time.F90 b/src/specfem3D/iterate_time.F90 index cd810df3d..a62581aea 100644 --- a/src/specfem3D/iterate_time.F90 +++ b/src/specfem3D/iterate_time.F90 @@ -218,7 +218,7 @@ subroutine iterate_time() else ! forward simulations do istage = 1, NSTAGE_TIME_SCHEME - if(USE_LDDRK) call update_displ_lddrk() + if (USE_LDDRK) call update_displ_lddrk() ! 1. acoustic domain if (ACOUSTIC_SIMULATION) call compute_forces_acoustic() ! 2. elastic domain diff --git a/src/specfem3D/locate_source.F90 b/src/specfem3D/locate_source.F90 index a47c42510..50e7d211b 100644 --- a/src/specfem3D/locate_source.F90 +++ b/src/specfem3D/locate_source.F90 @@ -892,7 +892,7 @@ subroutine locate_source(ibool,NSOURCES,myrank,NSPEC_AB,NGLOB_AB,NGNOD, & write(IMAIN,*) ' using Gaussian source time function' endif if (idomain(isource) == IDOMAIN_ACOUSTIC) then - if(USE_TRICK_FOR_BETTER_PRESSURE) then + if (USE_TRICK_FOR_BETTER_PRESSURE) then write(IMAIN,*) ' using trick for better pressure (second derivatives)' endif endif diff --git a/src/specfem3D/noise_tomography.f90 b/src/specfem3D/noise_tomography.f90 index 2ce169aa8..274af28f2 100644 --- a/src/specfem3D/noise_tomography.f90 +++ b/src/specfem3D/noise_tomography.f90 @@ -25,7 +25,6 @@ ! !===================================================================== - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ATTENTION !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! This file is first implemented for SPECFEM3D_GLOBE, and therefore it follows variables in GLOBAL package. @@ -156,7 +155,7 @@ subroutine noise_distribution_dir_non_uni(xcoord_in,ycoord_in,zcoord_in, & !PB NOT UNIF DISTRIBUTION OF NOISE ON THE SURFACE OF A SPHERE !PB lon lat colat ARE IN RADIANS SINCE ARE OBTAINED FROM CARTESIAN COORDINATES !PB lon_cn lat_cn (cn = CENTER OF NOISE REGION) IF NOT, MUST BE CONVERTED IN RADIANS - !PB lon_cn lat_cn ARE INSERTED DIRECTLY HERE FOR SIMPLICITY + !PB lon_cn lat_cn are inserted directly here for simplicity lon_cn = (3.89)*PI/180 lat_cn = (45.113)*PI/180 diff --git a/src/specfem3D/pml_compute_accel_contribution.f90 b/src/specfem3D/pml_compute_accel_contribution.f90 index 65449bead..c15ee3e57 100644 --- a/src/specfem3D/pml_compute_accel_contribution.f90 +++ b/src/specfem3D/pml_compute_accel_contribution.f90 @@ -33,7 +33,7 @@ subroutine pml_compute_accel_contribution_elastic(ispec,ispec_CPML,displ,veloc,r ! second-order accurate convolution term calculation from equation (21) of ! Shumin Wang, Robert Lee, and Fernando L. Teixeira, - ! Anisotropic-Medium PML for Vector FETD With Modified Basis Functions, + ! Anisotropic-medium PML for vector FETD with modified basis functions, ! IEEE Transactions on Antennas and Propagation, vol. 54, no. 1, (2006) use specfem_par, only: NGLOB_AB,deltat,wgll_cube,jacobian,ibool,rhostore @@ -150,7 +150,7 @@ subroutine pml_compute_accel_contribution_acoustic(ispec,ispec_CPML,potential_ac ! second-order accurate convolution term calculation from equation (21) of ! Shumin Wang, Robert Lee, and Fernando L. Teixeira, - ! Anisotropic-Medium PML for Vector FETD With Modified Basis Functions, + ! Anisotropic-medium PML for vector FETD with modified basis functions, ! IEEE Transactions on Antennas and Propagation, vol. 54, no. 1, (2006) use specfem_par, only: NGLOB_AB,deltat,wgll_cube,jacobian,ibool,kappastore diff --git a/src/specfem3D/pml_compute_memory_variables.f90 b/src/specfem3D/pml_compute_memory_variables.f90 index ece42e84f..822e02025 100644 --- a/src/specfem3D/pml_compute_memory_variables.f90 +++ b/src/specfem3D/pml_compute_memory_variables.f90 @@ -39,7 +39,7 @@ subroutine pml_compute_memory_variables_elastic(ispec,ispec_CPML,tempx1,tempy1,t ! second-order accurate convolution term calculation from equation (21) of ! Shumin Wang, Robert Lee, and Fernando L. Teixeira, - ! Anisotropic-Medium PML for Vector FETD With Modified Basis Functions, + ! Anisotropic-medium PML for vector FETD with modified basis functions, ! IEEE Transactions on Antennas and Propagation, vol. 54, no. 1, (2006) use specfem_par, only: deltat,xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,jacobian, & @@ -358,7 +358,7 @@ subroutine pml_compute_memory_variables_acoustic(ispec,ispec_CPML,temp1,temp2,te ! second-order accurate convolution term calculation from equation (21) of ! Shumin Wang, Robert Lee, and Fernando L. Teixeira, - ! Anisotropic-Medium PML for Vector FETD With Modified Basis Functions, + ! Anisotropic-medium PML for vector FETD with modified basis functions, ! IEEE Transactions on Antennas and Propagation, vol. 54, no. 1, (2006) use specfem_par, only: xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,jacobian,& @@ -517,7 +517,7 @@ subroutine pml_compute_memory_variables_acoustic_elastic(ispec_CPML,iface,iglob, ! second-order accurate convolution term calculation from equation (21) of ! Shumin Wang, Robert Lee, and Fernando L. Teixeira, - ! Anisotropic-Medium PML for Vector FETD With Modified Basis Functions, + ! Anisotropic-medium PML for vector FETD with modified basis functions, ! IEEE Transactions on Antennas and Propagation, vol. 54, no. 1, (2006) use specfem_par, only: NGLOB_AB,deltat @@ -604,7 +604,7 @@ subroutine pml_compute_memory_variables_elastic_acoustic(ispec_CPML,iface,iglob, ! second-order accurate convolution term calculation from equation (21) of ! Shumin Wang, Robert Lee, and Fernando L. Teixeira, - ! Anisotropic-Medium PML for Vector FETD With Modified Basis Functions, + ! Anisotropic-medium PML for vector FETD with modified basis functions, ! IEEE Transactions on Antennas and Propagation, vol. 54, no. 1, (2006) use specfem_par, only: NGLOB_AB,deltat diff --git a/src/specfem3D/prepare_timerun.F90 b/src/specfem3D/prepare_timerun.F90 index f270bbd2c..03993dbbd 100644 --- a/src/specfem3D/prepare_timerun.F90 +++ b/src/specfem3D/prepare_timerun.F90 @@ -73,7 +73,7 @@ subroutine prepare_timerun() ! prepares gravity arrays call prepare_timerun_gravity() - ! ZN I do not use if(USE_LDDRK) call prepare_timerun_lddrk() + ! ZN I do not use if (USE_LDDRK) call prepare_timerun_lddrk() ! ZN in order to avoid the error of using unallocated arrays later on in the code, ! ZN since R_**_lddrk are arguments in subroutine compute_forces_viscoelastic call prepare_timerun_lddrk() @@ -979,7 +979,7 @@ subroutine prepare_timerun_adjoint() endif ! initializes adjoint kernels and reconstructed/backward wavefields - if (SIMULATION_TYPE == 3) then + if (SIMULATION_TYPE == 3) then ! elastic domain if (ELASTIC_SIMULATION) then rho_kl(:,:,:,:) = 0._CUSTOM_REAL diff --git a/src/specfem3D/setup_sources_receivers.f90 b/src/specfem3D/setup_sources_receivers.f90 index dcf0f8ade..b48220ee3 100644 --- a/src/specfem3D/setup_sources_receivers.f90 +++ b/src/specfem3D/setup_sources_receivers.f90 @@ -631,7 +631,7 @@ subroutine setup_sources_precompute_arrays() logical :: does_source_encoding ! for source encoding (acoustic sources only so far) - if(USE_SOURCE_ENCODING) then + if (USE_SOURCE_ENCODING) then allocate(pm1_source_encoding(NSOURCES),stat=ier) else allocate(pm1_source_encoding(1),stat=ier) diff --git a/src/specfem3D/specfem3D_adios_stubs.f90 b/src/specfem3D/specfem3D_adios_stubs.f90 index a7b895014..f2831da1a 100644 --- a/src/specfem3D/specfem3D_adios_stubs.f90 +++ b/src/specfem3D/specfem3D_adios_stubs.f90 @@ -35,7 +35,7 @@ !============================================================================== !------------------------------------------------. -! Subroutines from read_mesh_databases_adios.F90 | +! subroutines from read_mesh_databases_adios.F90 | !------------------------------------------------' subroutine read_mesh_for_init_ADIOS(nspec, nglob) @@ -65,7 +65,7 @@ subroutine read_mesh_databases_moho_adios() end subroutine read_mesh_databases_moho_adios !-----------------------------------------. -! Subroutines from save_kernels_adios.F90 | +! subroutines from save_kernels_adios.F90 | !-----------------------------------------' subroutine define_kernel_adios_variables(handle, SAVE_WEIGHTS) @@ -171,7 +171,7 @@ subroutine save_kernels_hessian_adios(handle) end subroutine save_kernels_hessian_adios !------------------------------------------------. -! Subroutines from save_forward_arrays_adios.F90 | +! subroutines from save_forward_arrays_adios.F90 | !------------------------------------------------' subroutine save_forward_arrays_adios() @@ -181,7 +181,7 @@ subroutine save_forward_arrays_adios() end subroutine save_forward_arrays_adios !------------------------------------------------. -! Subroutines from read_forward_arrays_adios.F90 | +! subroutines from read_forward_arrays_adios.F90 | !------------------------------------------------' subroutine read_forward_arrays_adios() diff --git a/src/specfem3D/write_output_ASCII_or_binary.f90 b/src/specfem3D/write_output_ASCII_or_binary.f90 index 867224466..ece8db8fe 100644 --- a/src/specfem3D/write_output_ASCII_or_binary.f90 +++ b/src/specfem3D/write_output_ASCII_or_binary.f90 @@ -65,7 +65,7 @@ subroutine write_output_ASCII_or_binary(one_seismogram, & if (ier /= 0) stop 'error allocating array tr()' ! binary format case - if(.not. SAVE_ALL_SEISMOS_IN_ONE_FILE) then + if (.not. SAVE_ALL_SEISMOS_IN_ONE_FILE) then open(unit=IOUT, file=final_LOCAL_PATH(1:len_trim(final_LOCAL_PATH))//& sisname(1:len_trim(sisname)), form='unformatted', access='direct', recl=4*(nt_s)) else @@ -76,7 +76,7 @@ subroutine write_output_ASCII_or_binary(one_seismogram, & else ! ASCII format case - if(.not. SAVE_ALL_SEISMOS_IN_ONE_FILE) then + if (.not. SAVE_ALL_SEISMOS_IN_ONE_FILE) then open(unit=IOUT,file=final_LOCAL_PATH(1:len_trim(final_LOCAL_PATH))//& sisname(1:len_trim(sisname)),status='unknown') else @@ -104,7 +104,7 @@ subroutine write_output_ASCII_or_binary(one_seismogram, & if (USE_BINARY_FOR_SEISMOGRAMS) then ! binary format case - if(.not. SAVE_ALL_SEISMOS_IN_ONE_FILE) then + if (.not. SAVE_ALL_SEISMOS_IN_ONE_FILE) then tr(isample) = one_seismogram(iorientation,isample) else write(IOUT) time_t,one_seismogram(iorientation,isample) @@ -119,11 +119,11 @@ subroutine write_output_ASCII_or_binary(one_seismogram, & ! binary format case if (USE_BINARY_FOR_SEISMOGRAMS) then ! writes out whole trace into binary file - if(.not. SAVE_ALL_SEISMOS_IN_ONE_FILE) write(IOUT,rec=1) tr + if (.not. SAVE_ALL_SEISMOS_IN_ONE_FILE) write(IOUT,rec=1) tr deallocate(tr) endif - if(.not. SAVE_ALL_SEISMOS_IN_ONE_FILE) close(IOUT) + if (.not. SAVE_ALL_SEISMOS_IN_ONE_FILE) close(IOUT) end subroutine write_output_ASCII_or_binary diff --git a/src/specfem3D/write_seismograms.f90 b/src/specfem3D/write_seismograms.f90 index edec78789..49367a8b9 100644 --- a/src/specfem3D/write_seismograms.f90 +++ b/src/specfem3D/write_seismograms.f90 @@ -308,34 +308,34 @@ subroutine write_seismograms() if (SIMULATION_TYPE == 2) then ! adjoint simulations ! adjoint "receiver" N/E/Z orientations given by nu_source array - if(SAVE_SEISMOGRAMS_DISPLACEMENT) & + if (SAVE_SEISMOGRAMS_DISPLACEMENT) & seismograms_d(:,irec_local,it) = real(nu_source(:,1,irec)*dxd & + nu_source(:,2,irec)*dyd & + nu_source(:,3,irec)*dzd,kind=CUSTOM_REAL) - if(SAVE_SEISMOGRAMS_VELOCITY) & + if (SAVE_SEISMOGRAMS_VELOCITY) & seismograms_v(:,irec_local,it) = real(nu_source(:,1,irec)*vxd & + nu_source(:,2,irec)*vyd & + nu_source(:,3,irec)*vzd,kind=CUSTOM_REAL) - if(SAVE_SEISMOGRAMS_ACCELERATION) & + if (SAVE_SEISMOGRAMS_ACCELERATION) & seismograms_a(:,irec_local,it) = real(nu_source(:,1,irec)*axd & + nu_source(:,2,irec)*ayd & + nu_source(:,3,irec)*azd,kind=CUSTOM_REAL) else ! forward & kernel simulations - if(SAVE_SEISMOGRAMS_DISPLACEMENT) & + if (SAVE_SEISMOGRAMS_DISPLACEMENT) & seismograms_d(:,irec_local,it) = real(nu(:,1,irec)*dxd + nu(:,2,irec)*dyd + nu(:,3,irec)*dzd,kind=CUSTOM_REAL) - if(SAVE_SEISMOGRAMS_VELOCITY) & + if (SAVE_SEISMOGRAMS_VELOCITY) & seismograms_v(:,irec_local,it) = real(nu(:,1,irec)*vxd + nu(:,2,irec)*vyd + nu(:,3,irec)*vzd,kind=CUSTOM_REAL) - if(SAVE_SEISMOGRAMS_ACCELERATION) & + if (SAVE_SEISMOGRAMS_ACCELERATION) & seismograms_a(:,irec_local,it) = real(nu(:,1,irec)*axd + nu(:,2,irec)*ayd + nu(:,3,irec)*azd,kind=CUSTOM_REAL) endif ! only one scalar in the case of pressure - if(SAVE_SEISMOGRAMS_PRESSURE) & + if (SAVE_SEISMOGRAMS_PRESSURE) & seismograms_p(1,irec_local,it) = real(pd,kind=CUSTOM_REAL) ! adjoint simulations @@ -349,23 +349,23 @@ subroutine write_seismograms() if ((mod(it,NTSTEP_BETWEEN_OUTPUT_SEISMOS) == 0 .or. it == NSTEP) .and. .not. SU_FORMAT) then if (SIMULATION_TYPE == 2) then ! adjoint simulations - if(SAVE_SEISMOGRAMS_DISPLACEMENT) & + if (SAVE_SEISMOGRAMS_DISPLACEMENT) & call write_adj_seismograms_to_file(myrank,seismograms_d,number_receiver_global,nrec_local,it,DT,NSTEP,t0,1) - if(SAVE_SEISMOGRAMS_VELOCITY) & + if (SAVE_SEISMOGRAMS_VELOCITY) & call write_adj_seismograms_to_file(myrank,seismograms_v,number_receiver_global,nrec_local,it,DT,NSTEP,t0,2) - if(SAVE_SEISMOGRAMS_ACCELERATION) & + if (SAVE_SEISMOGRAMS_ACCELERATION) & call write_adj_seismograms_to_file(myrank,seismograms_a,number_receiver_global,nrec_local,it,DT,NSTEP,t0,3) - if(SAVE_SEISMOGRAMS_PRESSURE) & + if (SAVE_SEISMOGRAMS_PRESSURE) & call write_adj_seismograms_to_file(myrank,seismograms_p,number_receiver_global,nrec_local,it,DT,NSTEP,t0,4) else ! forward & kernel simulations - if(SAVE_SEISMOGRAMS_DISPLACEMENT) & + if (SAVE_SEISMOGRAMS_DISPLACEMENT) & call write_seismograms_to_file(seismograms_d,1) - if(SAVE_SEISMOGRAMS_VELOCITY) & + if (SAVE_SEISMOGRAMS_VELOCITY) & call write_seismograms_to_file(seismograms_v,2) - if(SAVE_SEISMOGRAMS_ACCELERATION) & + if (SAVE_SEISMOGRAMS_ACCELERATION) & call write_seismograms_to_file(seismograms_a,3) - if(SAVE_SEISMOGRAMS_PRESSURE) & + if (SAVE_SEISMOGRAMS_PRESSURE) & call write_seismograms_to_file(seismograms_p,4) endif endif @@ -595,7 +595,7 @@ subroutine write_one_seismogram(one_seismogram,irec, & character(len=3) :: channel ! see how many components we need to store: 1 for pressure, NDIM for a vector - if(istore == 4) then ! this is for pressure + if (istore == 4) then ! this is for pressure number_of_components = 1 else number_of_components = NDIM @@ -605,7 +605,7 @@ subroutine write_one_seismogram(one_seismogram,irec, & do iorientation = 1,number_of_components ! gets channel name - if(istore == 4) then ! this is for pressure + if (istore == 4) then ! this is for pressure call write_channel_name(istore,channel) else call write_channel_name(iorientation,channel) @@ -683,7 +683,7 @@ subroutine write_adj_seismograms_to_file(myrank,seismograms,number_receiver_glob irec = number_receiver_global(irec_local) ! see how many components we need to store: 1 for pressure, NDIM for a vector - if(istore == 4) then ! this is for pressure + if (istore == 4) then ! this is for pressure number_of_components = 1 else number_of_components = NDIM @@ -693,7 +693,7 @@ subroutine write_adj_seismograms_to_file(myrank,seismograms,number_receiver_glob do iorientation = 1,number_of_components ! gets channel name - if(istore == 4) then ! this is for pressure + if (istore == 4) then ! this is for pressure call write_channel_name(istore,channel) else call write_channel_name(iorientation,channel) diff --git a/src/tomography/postprocess_sensitivity_kernels/smooth_sem.F90 b/src/tomography/postprocess_sensitivity_kernels/smooth_sem.F90 index f179f9ea6..49c51a2f3 100644 --- a/src/tomography/postprocess_sensitivity_kernels/smooth_sem.F90 +++ b/src/tomography/postprocess_sensitivity_kernels/smooth_sem.F90 @@ -436,7 +436,7 @@ program smooth_sem endif enddo - if( .not. do_include_slice) then + if ( .not. do_include_slice) then ! note: Gaussian support might be larger than closest neighbour slices ! we add all slices close enough to still have an influence diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/COPY_LOCAL/copy_local.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/COPY_LOCAL/copy_local.f90 index 3ed4a2155..4f53169b0 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/COPY_LOCAL/copy_local.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/FORWARD_ADJOINT/COPY_LOCAL/copy_local.f90 @@ -32,7 +32,7 @@ program xcopy_local !call system(trim(command)) ! copy command - if( myrank == 0 ) then + if ( myrank == 0 ) then cp = "cp -v" else cp = "cp" diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/gll_library.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/gll_library.f90 index 36986d6f7..d7580022f 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/gll_library.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/gll_library.f90 @@ -178,7 +178,7 @@ subroutine jacg (xjac,np,alpha,beta) pd = 0.d0 jmin = 0 do j=1,np - if(j == 1) then + if (j == 1) then x = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth) else x1 = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth) @@ -194,7 +194,7 @@ subroutine jacg (xjac,np,alpha,beta) enddo delx = -p/(pd-recsum*p) x = x+delx - if(abs(delx) < eps) goto 31 + if (abs(delx) < eps) goto 31 enddo 31 continue xjac(np-j+1) = x @@ -203,12 +203,12 @@ subroutine jacg (xjac,np,alpha,beta) do i=1,np xmin = 2.d0 do j=i,np - if(xjac(j) < xmin) then + if (xjac(j) < xmin) then xmin = xjac(j) jmin = j endif enddo - if(jmin /= i) then + if (jmin /= i) then swap = xjac(i) xjac(i) = xjac(jmin) xjac(jmin) = swap @@ -279,7 +279,7 @@ end subroutine jacobf !------------------------------------------------------------------------ ! - double precision FUNCTION PNDLEG (Z,N) + double precision function PNDLEG (Z,N) !------------------------------------------------------------------------ ! @@ -319,7 +319,7 @@ end function pndleg !------------------------------------------------------------------------ ! - double precision FUNCTION PNLEG (Z,N) + double precision function PNLEG (Z,N) !------------------------------------------------------------------------ ! diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/smooth_sem_globe.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/smooth_sem_globe.f90 index 9662a8421..d5625459f 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/smooth_sem_globe.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X03_SRC_SMOOTH_KERNELS/smooth_sem_globe.f90 @@ -211,7 +211,7 @@ program smooth_sem_globe enddo nums = j - if( myrank == 0 ) then + if ( myrank == 0 ) then print *,'slices:',nums print *,' ',islice(:) print * @@ -233,7 +233,7 @@ program smooth_sem_globe ! point locations open(11,file=solver2_file(1),status='old',form='unformatted',iostat=ier) - if( ier /= 0 ) call exit_mpi(myrank,'error opening solver2 file') + if ( ier /= 0 ) call exit_mpi(myrank,'error opening solver2 file') read(11) x(1:nglob(1)) read(11) y(1:nglob(1)) @@ -243,7 +243,7 @@ program smooth_sem_globe ! jacobian open(11,file=solver1_file(1),status='old',form='unformatted',iostat=ier) - if( ier /= 0 ) call exit_mpi(myrank,'error opening solver1 file') + if ( ier /= 0 ) call exit_mpi(myrank,'error opening solver1 file') read(11) xix read(11) xiy @@ -312,7 +312,7 @@ program smooth_sem_globe ! point locations ! given in cartesian coordinates open(11,file=solver2_file(iproc),status='old',form='unformatted',iostat=ier) - if( ier /= 0 ) call exit_mpi(myrank,'error opening slices: solver2 file') + if ( ier /= 0 ) call exit_mpi(myrank,'error opening slices: solver2 file') read(11) x(1:nglob(iproc)) read(11) y(1:nglob(iproc)) @@ -321,7 +321,7 @@ program smooth_sem_globe close(11) open(11,file=solver1_file(iproc),status='old',form='unformatted',iostat=ier) - if( ier /= 0 ) call exit_mpi(myrank,'error opening slices: solver1 file') + if ( ier /= 0 ) call exit_mpi(myrank,'error opening slices: solver1 file') read(11) xix read(11) xiy @@ -362,7 +362,7 @@ program smooth_sem_globe ! kernel file open(11,file=k_file(iproc),status='old',form='unformatted',iostat=ier) - if( ier /= 0 ) call exit_mpi(myrank,'error opening kernel file') + if ( ier /= 0 ) call exit_mpi(myrank,'error opening kernel file') read(11) kernel(:,:,:,1:nspec(iproc)) close(11) @@ -439,7 +439,7 @@ program smooth_sem_globe bk(i,j,k,ispec) = bk(i,j,k,ispec) + sum(exp_val(:,:,:)) ! checks number - !if( isNaN(tk(i,j,k,ispec)) ) then + !if ( isNaN(tk(i,j,k,ispec)) ) then ! print *,'error tk NaN: ',tk(i,j,k,ispec) ! print *,'rank:',myrank ! print *,'i,j,k,ispec:',i,j,k,ispec @@ -478,7 +478,7 @@ program smooth_sem_globe ! checks number - if( isNaN(kernel_smooth(i,j,k,ispec)) ) then + if ( isNaN(kernel_smooth(i,j,k,ispec)) ) then print *,'error kernel_smooth NaN: ',kernel_smooth(i,j,k,ispec) print *,'rank:',myrank print *,'i,j,k,ispec:',i,j,k,ispec @@ -494,7 +494,7 @@ program smooth_sem_globe ! file output open(11,file=trim(ks_file),status='unknown',form='unformatted',iostat=ier) - if( ier /= 0 ) call exit_mpi(myrank,'error opening smoothed kernel file') + if ( ier /= 0 ) call exit_mpi(myrank,'error opening smoothed kernel file') ! Note: output the following instead of kernel_smooth(:,:,:,1:nspec(1)) to create files of the same sizes write(11) kernel_smooth(:,:,:,:) @@ -566,7 +566,7 @@ subroutine smoothing_weights_vec(x0,y0,z0,ispec2,sigma_h2,sigma_v2,exp_val,& ! checks number - !if( isNaN(exp_val(ii,jj,kk)) ) then + !if ( isNaN(exp_val(ii,jj,kk)) ) then ! print *,'error exp_val NaN: ',exp_val(ii,jj,kk) ! print *,'i,j,k:',ii,jj,kk ! print *,'dist_h: ',dist_h,'dist_v:',dist_v @@ -614,8 +614,8 @@ subroutine get_distance_vec(dist_h,dist_v,x0,y0,z0,x1,y1,z1) ratio = (x0*x1 + y0*y1 + z0*z1)/(r0 * r1) ! checks boundaries of ratio (due to numerical inaccuracies) - if( ratio > 1.0_CUSTOM_REAL ) ratio = 1.0_CUSTOM_REAL - if( ratio < -1.0_CUSTOM_REAL ) ratio = -1.0_CUSTOM_REAL + if ( ratio > 1.0_CUSTOM_REAL ) ratio = 1.0_CUSTOM_REAL + if ( ratio < -1.0_CUSTOM_REAL ) ratio = -1.0_CUSTOM_REAL theta = acos( ratio ) diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/compute_direction_lbfgs.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/compute_direction_lbfgs.f90 index d6b537844..a5c068c68 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/compute_direction_lbfgs.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X04_SRC_DIRECTION_LBFGS/compute_direction_lbfgs.f90 @@ -165,7 +165,7 @@ subroutine get_ibool write(dirname,'(a)') '/scratch/lustre/hejunzhu/2012SHEAR_ATTENUATION_ITERATION_UPDATE/EUROPE_TOPOLOGY_FILE' write(filename,'(a,i6.6,a)') trim(dirname)//'/proc',myrank,'_reg1_solver_data_2.bin' open(1001,file=trim(filename),status='old',form='unformatted',iostat=ier) - if( ier /= 0 ) call exit_mpi(myrank,'error opening solver2 file') + if ( ier /= 0 ) call exit_mpi(myrank,'error opening solver2 file') read(1001) tmp(1:NGLOB) read(1001) tmp(1:NGLOB) read(1001) tmp(1:NGLOB) diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/add_model_globe.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/add_model_globe.f90 index ad8fc814c..5549002e5 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/add_model_globe.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/add_model_globe.f90 @@ -162,7 +162,7 @@ program add_model alphah1 = 0._CUSTOM_REAL ! do not use transverse isotropy except if element is between d220 and Moho - if(.not. ( idoubling(ispec)== IFLAG_670_220 .or.idoubling(ispec)==IFLAG_220_80 .or. idoubling(ispec)==IFLAG_80_MOHO) ) then + if (.not. ( idoubling(ispec)== IFLAG_670_220 .or.idoubling(ispec)==IFLAG_220_80 .or. idoubling(ispec)==IFLAG_80_MOHO) ) then ! isotropic model update @@ -198,8 +198,8 @@ program add_model ! eta value : limits updated values for eta range constraint eta1 = eta0 * exp( model_deta(i,j,k,ispec) ) - if( eta1 < LIMIT_ETA_MIN ) eta1 = LIMIT_ETA_MIN - if( eta1 > LIMIT_ETA_MAX ) eta1 = LIMIT_ETA_MAX + if ( eta1 < LIMIT_ETA_MIN ) eta1 = LIMIT_ETA_MIN + if ( eta1 > LIMIT_ETA_MAX ) eta1 = LIMIT_ETA_MAX ! shear values betav1 = betav0 * exp( model_dbetav(i,j,k,ispec) ) @@ -263,7 +263,7 @@ subroutine initialize() call MPI_COMM_SIZE(MPI_COMM_WORLD,sizeprocs,ier) call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier) - if( sizeprocs /= nchunks_val*nproc_xi_val*nproc_eta_val ) then + if ( sizeprocs /= nchunks_val*nproc_xi_val*nproc_eta_val ) then print *,'sizeprocs:',sizeprocs,nchunks_val,nproc_xi_val,nproc_eta_val call exit_mpi(myrank,'error number sizeprocs') endif @@ -333,7 +333,7 @@ subroutine read_parameters() ! read in parameter information read(s_step_fac,*) step_fac - !if( abs(step_fac) < 1.e-10) then + !if ( abs(step_fac) < 1.e-10) then ! print *,'error: step factor ',step_fac ! call exit_MPI(myrank,'error step factor') !endif @@ -369,7 +369,7 @@ subroutine read_model() ! vpv model write(m_file,'(a,i6.6,a)') trim(input_model)//'/proc',myrank,'_reg1_vpv.bin' open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier) - if( ier /= 0 ) then + if ( ier /= 0 ) then print *,'error opening: ',trim(m_file) call exit_mpi(myrank,'file not found') endif @@ -379,7 +379,7 @@ subroutine read_model() ! vph model write(m_file,'(a,i6.6,a)') trim(input_model)//'/proc',myrank,'_reg1_vph.bin' open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier) - if( ier /= 0 ) then + if ( ier /= 0 ) then print *,'error opening: ',trim(m_file) call exit_mpi(myrank,'file not found') endif @@ -389,7 +389,7 @@ subroutine read_model() ! vsv model write(m_file,'(a,i6.6,a)') trim(input_model)//'/proc',myrank,'_reg1_vsv.bin' open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier) - if( ier /= 0 ) then + if ( ier /= 0 ) then print *,'error opening: ',trim(m_file) call exit_mpi(myrank,'file not found') endif @@ -399,7 +399,7 @@ subroutine read_model() ! vsh model write(m_file,'(a,i6.6,a)') trim(input_model)//'/proc',myrank,'_reg1_vsh.bin' open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier) - if( ier /= 0 ) then + if ( ier /= 0 ) then print *,'error opening: ',trim(m_file) call exit_mpi(myrank,'file not found') endif @@ -409,7 +409,7 @@ subroutine read_model() ! eta model write(m_file,'(a,i6.6,a)') trim(input_model)//'/proc',myrank,'_reg1_eta.bin' open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier) - if( ier /= 0 ) then + if ( ier /= 0 ) then print *,'error opening: ',trim(m_file) call exit_mpi(myrank,'file not found') endif @@ -419,7 +419,7 @@ subroutine read_model() ! rho model write(m_file,'(a,i6.6,a)') trim(input_model)//'/proc',myrank,'_reg1_rho.bin' open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier) - if( ier /= 0 ) then + if ( ier /= 0 ) then print *,'error opening: ',trim(m_file) call exit_mpi(myrank,'file not found') endif @@ -445,7 +445,7 @@ subroutine read_model() call mpi_reduce(minval(model_rho),min_rho,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier) call mpi_reduce(maxval(model_rho),max_rho,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier) - if( myrank == 0 ) then + if ( myrank == 0 ) then print *,'initial models:' print *,' vpv min/max: ',min_vpv,max_vpv print *,' vph min/max: ',min_vph,max_vph @@ -472,7 +472,7 @@ subroutine read_kernels() ! bulk kernel write(m_file,'(a,i6.6,a)') trim(input_kernel)//'/proc',myrank,'_reg1_bulk_c_kernel_precond_smooth.bin' open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier) - if( ier /= 0 ) then + if ( ier /= 0 ) then print *,'error opening: ',trim(m_file) call exit_mpi(myrank,'file not found') endif @@ -482,7 +482,7 @@ subroutine read_kernels() ! betav kernel write(m_file,'(a,i6.6,a)') trim(input_kernel)//'/proc',myrank,'_reg1_bulk_betav_kernel_precond_smooth.bin' open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier) - if( ier /= 0 ) then + if ( ier /= 0 ) then print *,'error opening: ',trim(m_file) call exit_mpi(myrank,'file not found') endif @@ -492,7 +492,7 @@ subroutine read_kernels() ! betah kernel write(m_file,'(a,i6.6,a)') trim(input_kernel)//'/proc',myrank,'_reg1_bulk_betah_kernel_precond_smooth.bin' open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier) - if( ier /= 0 ) then + if ( ier /= 0 ) then print *,'error opening: ',trim(m_file) call exit_mpi(myrank,'file not found') endif @@ -502,7 +502,7 @@ subroutine read_kernels() ! eta kernel write(m_file,'(a,i6.6,a)') trim(input_kernel)//'/proc',myrank,'_reg1_eta_kernel_precond_smooth.bin' open(12,file=trim(m_file),status='old',form='unformatted',iostat=ier) - if( ier /= 0 ) then + if ( ier /= 0 ) then print *,'error opening: ',trim(m_file) call exit_mpi(myrank,'file not found') endif @@ -523,7 +523,7 @@ subroutine read_kernels() call mpi_reduce(minval(kernel_eta),min_eta,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier) call mpi_reduce(maxval(kernel_eta),max_eta,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier) - if( myrank == 0 ) then + if ( myrank == 0 ) then print *,'initial kernels:' print *,' bulk min/max : ',min_bulk,max_bulk print *,' betav min/max: ',min_vsv,max_vsv @@ -580,7 +580,7 @@ subroutine compute_volume() write(m_file,'(a,i6.6,a)') & '/tigress-hsm/hejunzhu/2011EUROPE_ITERATION_UPDATE/EUROPE_TOPOLOGY_FILE/proc',myrank,'_reg1_solver_data_2.bin' open(11,file=trim(m_file),status='old',form='unformatted',iostat=ier) - if( ier /= 0 ) then + if ( ier /= 0 ) then print *,'error opening: ',trim(m_file) call exit_mpi(myrank,'file not found') endif @@ -595,7 +595,7 @@ subroutine compute_volume() write(m_file,'(a,i6.6,a)') & '/tigress-hsm/hejunzhu/2011EUROPE_ITERATION_UPDATE/EUROPE_TOPOLOGY_FILE/proc',myrank,'_reg1_solver_data_1.bin' open(11,file=trim(m_file),status='old',form='unformatted',iostat=ier) - if( ier /= 0 ) then + if ( ier /= 0 ) then print *,'error opening: ',trim(m_file) call exit_mpi(myrank,'file not found') endif @@ -631,7 +631,7 @@ subroutine compute_volume() + xizl*(etaxl*gammayl-etayl*gammaxl)) jacobian(i,j,k,ispec) = jacobianl - !if( abs(jacobianl) < 1.e-8 ) then + !if ( abs(jacobianl) < 1.e-8 ) then ! print *,'rank ',myrank,'jacobian: ',jacobianl,i,j,k,wgll_cube(i,j,k) !endif @@ -655,7 +655,7 @@ subroutine compute_volume() do j = 1, NGLLY do i = 1, NGLLX iglob = ibool(i,j,k,ispec) - if( iglob == 0 ) then + if ( iglob == 0 ) then print *,'iglob zero',i,j,k,ispec print * print *,'ibool:',ispec @@ -688,7 +688,7 @@ subroutine compute_volume() norm_eta = norm_eta + kernel_eta(i,j,k,ispec)*kernel_eta(i,j,k,ispec) ! checks number - if( isNaN(integral_bulk) ) then + if ( isNaN(integral_bulk) ) then print *,'error NaN: ',integral_bulk print *,'rank:',myrank print *,'i,j,k,ispec:',i,j,k,ispec @@ -709,7 +709,7 @@ subroutine compute_volume() call mpi_reduce(integral_eta,integral_eta_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier) call mpi_reduce(volume_glob,volume_glob_sum,1,CUSTOM_MPI_TYPE,MPI_SUM,0,MPI_COMM_WORLD,ier) - if( myrank == 0 ) then + if ( myrank == 0 ) then print *,'integral kernels:' print *,' bulk : ',integral_bulk_sum print *,' betav : ',integral_betav_sum @@ -731,7 +731,7 @@ subroutine compute_volume() norm_betah = sqrt(norm_betah_sum) norm_eta = sqrt(norm_eta_sum) - if( myrank == 0 ) then + if ( myrank == 0 ) then print *,'norm kernels:' print *,' bulk : ',norm_bulk print *,' betav : ',norm_betav @@ -782,16 +782,16 @@ subroutine get_gradient() model_deta(i,j,k,ispec) = kernel_eta(i,j,k,ispec) ! determines maximum kernel betav value within given radius - if( use_depth_maximum ) then + if ( use_depth_maximum ) then ! get radius of point iglob = ibool(i,j,k,ispec) r = sqrt( x(iglob)*x(iglob) + y(iglob)*y(iglob) + z(iglob)*z(iglob) ) ! stores maximum kernel betav value in this depth slice, since betav is most likely dominating - if( r < R_top .and. r > R_bottom ) then + if ( r < R_top .and. r > R_bottom ) then ! kernel betav value max_vsv = abs( kernel_betav(i,j,k,ispec) ) - if( max < max_vsv ) then + if ( max < max_vsv ) then max = max_vsv depth_max = r endif @@ -821,7 +821,7 @@ subroutine get_gradient() call mpi_reduce(minval(model_deta),min_eta,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier) call mpi_reduce(maxval(model_deta),max_eta,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier) - if( myrank == 0 ) then + if ( myrank == 0 ) then print *,'initial gradients:' print *,' bulk min/max : ',min_bulk,max_bulk print *,' betav min/max: ',min_vsv,max_vsv @@ -831,7 +831,7 @@ subroutine get_gradient() endif ! determines maximum kernel betav value within given radius - if( use_depth_maximum ) then + if ( use_depth_maximum ) then ! maximum of all processes stored in max_vsv call mpi_reduce(max,max_vsv,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier) max = max_vsv @@ -840,10 +840,10 @@ subroutine get_gradient() ! determines step length ! based on maximum gradient value (either vsv or vsh) - if( myrank == 0 ) then + if ( myrank == 0 ) then ! determines maximum kernel betav value within given radius - if( use_depth_maximum ) then + if ( use_depth_maximum ) then print *,' using depth maximum between 50km and 100km: ',max print *,' approximate depth maximum: ',depth_max print * @@ -886,7 +886,7 @@ subroutine get_gradient() norm_betah = sqrt(norm_betah_sum) norm_eta = sqrt(norm_eta_sum) - if( myrank == 0 ) then + if ( myrank == 0 ) then print *,'norm model updates:' print *,' bulk : ',norm_bulk print *,' betav: ',norm_betav @@ -915,7 +915,7 @@ subroutine get_gradient() call mpi_reduce(minval(model_deta),min_eta,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier) call mpi_reduce(maxval(model_deta),max_eta,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier) - if( myrank == 0 ) then + if ( myrank == 0 ) then print *,'scaled gradients:' print *,' bulk min/max : ',min_bulk,max_bulk print *,' betav min/max: ',min_vsv,max_vsv @@ -1030,7 +1030,7 @@ subroutine store_new_model() close(12) - if( myrank == 0 ) then + if ( myrank == 0 ) then print *,'new models:' print *,' vpv min/max: ',min_vpv,max_vpv print *,' vph min/max: ',min_vph,max_vph @@ -1121,7 +1121,7 @@ subroutine store_perturbations() call mpi_reduce(maxval(total_model),max_rho,1,CUSTOM_MPI_TYPE,MPI_MAX,0,MPI_COMM_WORLD,ier) call mpi_reduce(minval(total_model),min_rho,1,CUSTOM_MPI_TYPE,MPI_MIN,0,MPI_COMM_WORLD,ier) - if( myrank == 0 ) then + if ( myrank == 0 ) then print *,'relative update:' print *,' dvpv/vpv min/max: ',min_vpv,max_vpv print *,' dvph/vph min/max: ',min_vph,max_vph diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/gll_library.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/gll_library.f90 index 36986d6f7..d7580022f 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/gll_library.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/ITERATION_UPDATE/X05_SRC_UPDATE_MODELS/gll_library.f90 @@ -178,7 +178,7 @@ subroutine jacg (xjac,np,alpha,beta) pd = 0.d0 jmin = 0 do j=1,np - if(j == 1) then + if (j == 1) then x = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth) else x1 = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth) @@ -194,7 +194,7 @@ subroutine jacg (xjac,np,alpha,beta) enddo delx = -p/(pd-recsum*p) x = x+delx - if(abs(delx) < eps) goto 31 + if (abs(delx) < eps) goto 31 enddo 31 continue xjac(np-j+1) = x @@ -203,12 +203,12 @@ subroutine jacg (xjac,np,alpha,beta) do i=1,np xmin = 2.d0 do j=i,np - if(xjac(j) < xmin) then + if (xjac(j) < xmin) then xmin = xjac(j) jmin = j endif enddo - if(jmin /= i) then + if (jmin /= i) then swap = xjac(i) xjac(i) = xjac(jmin) xjac(jmin) = swap @@ -279,7 +279,7 @@ end subroutine jacobf !------------------------------------------------------------------------ ! - double precision FUNCTION PNDLEG (Z,N) + double precision function PNDLEG (Z,N) !------------------------------------------------------------------------ ! @@ -319,7 +319,7 @@ end function pndleg !------------------------------------------------------------------------ ! - double precision FUNCTION PNLEG (Z,N) + double precision function PNLEG (Z,N) !------------------------------------------------------------------------ ! diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/exit_mpi.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/exit_mpi.f90 index ed7e236b0..712c55d78 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/exit_mpi.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/exit_mpi.f90 @@ -60,7 +60,7 @@ subroutine exit_MPI(myrank,error_msg) close(IERROR) ! close output file - if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) close(IMAIN) + if (myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) close(IMAIN) ! stop all the MPI processes, and exit ! note: MPI_ABORT does not return, and does exit the diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/rthetaphi_xyz.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/rthetaphi_xyz.f90 index 3ad97c40e..6c7bf289d 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/rthetaphi_xyz.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_HORIZ/rthetaphi_xyz.f90 @@ -37,17 +37,17 @@ subroutine xyz_2_rthetaphi(x,y,z,r,theta,phi) double precision xmesh,ymesh,zmesh ! distinguish between single and double precision for reals - if(CUSTOM_REAL == SIZE_REAL) then + if (CUSTOM_REAL == SIZE_REAL) then xmesh = dble(x) ymesh = dble(y) zmesh = dble(z) - if(zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE - if(zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE + if (zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE + if (zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE theta = sngl(datan2(dsqrt(xmesh*xmesh+ymesh*ymesh),zmesh)) - if(xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE - if(xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE + if (xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE + if (xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE phi = sngl(datan2(ymesh,xmesh)) r = sngl(dsqrt(xmesh*xmesh + ymesh*ymesh + zmesh*zmesh)) @@ -58,11 +58,11 @@ subroutine xyz_2_rthetaphi(x,y,z,r,theta,phi) ymesh = y zmesh = z - if(zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE - if(zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE + if (zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE + if (zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE theta = datan2(dsqrt(xmesh*xmesh+ymesh*ymesh),zmesh) - if(xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE - if(xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE + if (xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE + if (xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE phi = datan2(ymesh,xmesh) r = dsqrt(xmesh*xmesh + ymesh*ymesh + zmesh*zmesh) @@ -88,13 +88,13 @@ subroutine xyz_2_rthetaphi_dble(x,y,z,r,theta,phi) ymesh = y zmesh = z - if(zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE - if(zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE + if (zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE + if (zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE theta = datan2(dsqrt(xmesh*xmesh+ymesh*ymesh),zmesh) - if(xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE - if(xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE + if (xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE + if (xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE phi = datan2(ymesh,xmesh) diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/exit_mpi.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/exit_mpi.f90 index ed7e236b0..712c55d78 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/exit_mpi.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/exit_mpi.f90 @@ -60,7 +60,7 @@ subroutine exit_MPI(myrank,error_msg) close(IERROR) ! close output file - if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) close(IMAIN) + if (myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) close(IMAIN) ! stop all the MPI processes, and exit ! note: MPI_ABORT does not return, and does exit the diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/rthetaphi_xyz.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/rthetaphi_xyz.f90 index 3ad97c40e..6c7bf289d 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/rthetaphi_xyz.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/MODEL_VISULIZATION/SRC_MODEL_SLICE_VERT/rthetaphi_xyz.f90 @@ -37,17 +37,17 @@ subroutine xyz_2_rthetaphi(x,y,z,r,theta,phi) double precision xmesh,ymesh,zmesh ! distinguish between single and double precision for reals - if(CUSTOM_REAL == SIZE_REAL) then + if (CUSTOM_REAL == SIZE_REAL) then xmesh = dble(x) ymesh = dble(y) zmesh = dble(z) - if(zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE - if(zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE + if (zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE + if (zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE theta = sngl(datan2(dsqrt(xmesh*xmesh+ymesh*ymesh),zmesh)) - if(xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE - if(xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE + if (xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE + if (xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE phi = sngl(datan2(ymesh,xmesh)) r = sngl(dsqrt(xmesh*xmesh + ymesh*ymesh + zmesh*zmesh)) @@ -58,11 +58,11 @@ subroutine xyz_2_rthetaphi(x,y,z,r,theta,phi) ymesh = y zmesh = z - if(zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE - if(zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE + if (zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE + if (zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE theta = datan2(dsqrt(xmesh*xmesh+ymesh*ymesh),zmesh) - if(xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE - if(xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE + if (xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE + if (xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE phi = datan2(ymesh,xmesh) r = dsqrt(xmesh*xmesh + ymesh*ymesh + zmesh*zmesh) @@ -88,13 +88,13 @@ subroutine xyz_2_rthetaphi_dble(x,y,z,r,theta,phi) ymesh = y zmesh = z - if(zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE - if(zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE + if (zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE + if (zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE theta = datan2(dsqrt(xmesh*xmesh+ymesh*ymesh),zmesh) - if(xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE - if(xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE + if (xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE + if (xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE phi = datan2(ymesh,xmesh) diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/gridsearch_time_moment.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/gridsearch_time_moment.f90 index 2d2bcbc41..3d9c1e82a 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/gridsearch_time_moment.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/ADJOINT_TOMOGRAPHY_TOOLKIT/SOURCE_INVERSION/SRC_GRIDSEARCH_INITIALTIME_MOMENT/gridsearch_time_moment.f90 @@ -306,7 +306,7 @@ subroutine xcorr_calc(d,s,npts,i1,i2,ishift,cc_max) ! cc as a function of i cc = 0. do j = i1, i2 ! loop over full window length - if((j+i)>=1 .and. (j+i)<=npts) cc = cc + s(j)*d(j+i) ! d is shifted by i + if ((j+i)>=1 .and. (j+i)<=npts) cc = cc + s(j)*d(j+i) ! d is shifted by i enddo cc = cc/norm diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/gll_library.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/gll_library.f90 index 73c78dbd6..8923f0530 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/gll_library.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/gll_library.f90 @@ -177,7 +177,7 @@ subroutine jacg (xjac,np,alpha,beta) pd = 0.d0 jmin = 0 do j=1,np - if(j == 1) then + if (j == 1) then x = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth) else x1 = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth) @@ -193,7 +193,7 @@ subroutine jacg (xjac,np,alpha,beta) enddo delx = -p/(pd-recsum*p) x = x+delx - if(abs(delx) < eps) goto 31 + if (abs(delx) < eps) goto 31 enddo 31 continue xjac(np-j+1) = x @@ -202,12 +202,12 @@ subroutine jacg (xjac,np,alpha,beta) do i=1,np xmin = 2.d0 do j=i,np - if(xjac(j) < xmin) then + if (xjac(j) < xmin) then xmin = xjac(j) jmin = j endif enddo - if(jmin /= i) then + if (jmin /= i) then swap = xjac(i) xjac(i) = xjac(jmin) xjac(jmin) = swap @@ -278,7 +278,7 @@ end subroutine jacobf !------------------------------------------------------------------------ ! - double precision FUNCTION PNDLEG (Z,N) + double precision function PNDLEG (Z,N) !------------------------------------------------------------------------ ! @@ -318,7 +318,7 @@ end function pndleg !------------------------------------------------------------------------ ! - double precision FUNCTION PNLEG (Z,N) + double precision function PNLEG (Z,N) !------------------------------------------------------------------------ ! diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/lagrange_poly.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/lagrange_poly.f90 index 041f29567..79224d9a0 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/lagrange_poly.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/lagrange_poly.f90 @@ -16,7 +16,7 @@ subroutine lagrange_poly(xi,NGLL,xigll,h,hprime) prod1 = 1.0d0 prod2 = 1.0d0 do i=1,NGLL - if(i /= dgr) then + if (i /= dgr) then prod1 = prod1*(xi-xigll(i)) prod2 = prod2*(xigll(dgr)-xigll(i)) endif @@ -25,10 +25,10 @@ subroutine lagrange_poly(xi,NGLL,xigll,h,hprime) hprime(dgr)=0.0d0 do i=1,NGLL - if(i /= dgr) then + if (i /= dgr) then prod1=1.0d0 do j=1,NGLL - if(j /= dgr .and. j /= i) prod1 = prod1*(xi-xigll(j)) + if (j /= dgr .and. j /= i) prod1 = prod1*(xi-xigll(j)) enddo hprime(dgr) = hprime(dgr)+prod1 endif diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/numerical_recipes.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/numerical_recipes.f90 index e1efdce2b..1e7d4a901 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/numerical_recipes.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/numerical_recipes.f90 @@ -13,7 +13,7 @@ double precision function erf(x) ! this routine uses routine gammp double precision gammp - if(x<0.)then + if (x<0.) then erf=-gammp(0.5d0,x**2) else erf=gammp(0.5d0,x**2) @@ -29,9 +29,9 @@ double precision function gammp(a,x) ! this routine uses routines gcf and gser double precision gammcf,gamser,gln - if(x<0.d0 .or. a <= 0.d0) stop 'bad arguments in gammp' + if (x<0.d0 .or. a <= 0.d0) stop 'bad arguments in gammp' - if(x 1) THEN + 1 if (KHI-KLO > 1) then K=(KHI+KLO)/2 - IF(XA(K) > X)THEN + if (XA(K) > X) then KHI=K ELSE KLO=K @@ -224,7 +224,7 @@ subroutine splint(xa,ya,y2a,n,x,y) goto 1 endif H=XA(KHI)-XA(KLO) - IF (H == 0.d0) stop 'Bad input in spline evaluation' + if (H == 0.d0) stop 'Bad input in spline evaluation' A=(XA(KHI)-X)/H B=(X-XA(KLO))/H diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d.f90 index c53241122..f425471a1 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d.f90 @@ -196,9 +196,9 @@ program wave2d ! idat=1 means we run simulations for both data and synthetics (two models) idat = 0 - if(IKER <= 4) idat = 1 - if(ISRC_SPACE==1) FINITE_SOURCE = 0 - if(ISRC_SPACE/=1) FINITE_SOURCE = 1 + if (IKER <= 4) idat = 1 + if (ISRC_SPACE==1) FINITE_SOURCE = 0 + if (ISRC_SPACE/=1) FINITE_SOURCE = 1 !-------------------------------------- ! load socal coast and shelf points @@ -318,7 +318,7 @@ program wave2d enddo close(15) - if(0==1) then + if (0==1) then ! corner points for each element, and centerpoint (in km) open(unit=15,file='elements.dat',status='unknown') @@ -419,7 +419,7 @@ program wave2d t_target = 2*hdur ! target period for phase velocity map - if(IMODEL <= 1) then + if (IMODEL <= 1) then ! write lat-lon gridpoints to file filename = trim(socal_dir) // 'socal_input.dat' @@ -455,7 +455,7 @@ program wave2d c_glob_syn(:) = c0 ! c-maps for synthetics - else if(IMODEL==2) then ! checkerboard + else if (IMODEL==2) then ! checkerboard c0 = 3500. ! reference phase velocity (m/s) (should be obtained based on hdur) !Nfac = 3 ! scalelength of map = N * (wavelength of surface waves for hdur) @@ -472,7 +472,7 @@ program wave2d c_glob_syn(:) = c0 ! c-maps for synthetics - else if(IMODEL==3) then ! read c-map for synthetics and data for a 'middle' iteration + else if (IMODEL==3) then ! read c-map for synthetics and data for a 'middle' iteration ! read in phase velocity map for data open(unit=16,file=trim(model_dir)//'socal_vel_dat.dat', status='unknown') @@ -510,7 +510,7 @@ program wave2d !c_glob_dat(:) = c_glob_syn(:) * (1. + afac/100.) ! unperturbed structure - if(PERT_STRUCT == 0) c_glob_syn(:) = c_glob_dat(:) + if (PERT_STRUCT == 0) c_glob_syn(:) = c_glob_dat(:) ! write data phase velocity map to file file_dat_c = 'socal_vel_dat.dat' @@ -572,7 +572,7 @@ program wave2d quake_file = 'socal_quakes_N025.dat' open(55,file=trim(in_dir)//trim(quake_file),status='unknown') read(55,*) nevent - if(nevent > MAX_EVENT) stop 'nevent > MAX_EVENT (so increase MAX_EVENT)' + if (nevent > MAX_EVENT) stop 'nevent > MAX_EVENT (so increase MAX_EVENT)' print *, nevent, ' target events (for synthetics)' read(55,'(i14,3f14.7)') (socal_events_lab(i),socal_events_lon(i),socal_events_lat(i),socal_events_mag(i),i=1,nevent) close(55) @@ -605,7 +605,7 @@ program wave2d call station_filter(nevent, x_eve0_dat, z_eve0_dat, ifilter_eve_dat, SOURCE_GRID_BUFFER) !call station_filter(nevent, x_eve, z_eve, dmin_trsh_s, ncoast, coast_x, coast_z) - if(nevent < 1) stop 'Must have at least one event' + if (nevent < 1) stop 'Must have at least one event' ! allocate variables allocate(x_eve_dat(nevent),z_eve_dat(nevent),x_eve_lon_dat(nevent),z_eve_lat_dat(nevent)) @@ -697,9 +697,9 @@ program wave2d allocate(ispec_eve(nevent),xi_eve(nevent),gamma_eve(nevent)) allocate(otime(nevent)) - if(PERT_SOURCE == 1) then ! source perturbations + if (PERT_SOURCE == 1) then ! source perturbations - if(1==1) then ! read in perturbed events from another file + if (1==1) then ! read in perturbed events from another file open(19,file='/home/store2/carltape/'//trim(out_dir3)//'run_2550/events_xy.dat',status='unknown') do ievent = 1,25 @@ -814,7 +814,7 @@ program wave2d ! get the lat-lon of the TARGET RECEIVERS -if(IREC_SPACE==1) then ! individual receivers +if (IREC_SPACE==1) then ! individual receivers ! target receiver !x_rec0(1) = 3 * LENGTH/4 ; z_rec0(1) = HEIGHT/2 @@ -833,7 +833,7 @@ program wave2d nrec = 3 -else if(IREC_SPACE==2) then ! actual station locations +else if (IREC_SPACE==2) then ! actual station locations ! read in (target) receivers recfile = trim(in_dir)//'STATION_149_full' @@ -845,7 +845,7 @@ program wave2d read(88,*) (x_rec_lon0(i),z_rec_lat0(i),i=1,nrec) close(88) -else if(IREC_SPACE==4) then ! 'regular' mesh of receivers +else if (IREC_SPACE==4) then ! 'regular' mesh of receivers ! calculate mesh spacing dx = LENGTH/NMESH_REC @@ -869,7 +869,7 @@ program wave2d endif ! IREC_SPACE ! make sure that there are fewer target points than the max allowed - if(nrec > MAX_SR) then + if (nrec > MAX_SR) then print * print *, ' IREC_SPACE = ', IREC_SPACE print *, ' nrec = ', nrec @@ -891,7 +891,7 @@ program wave2d !call station_filter(nrec, x_rec, z_rec, dmin_trsh_r, ncoast, coast_x, coast_z) !call station_filter_2(nrec, x_rec, z_rec, -1) ! -1 for left, +1 for right - if(nrec < 1) stop 'Must have at least one receiver' + if (nrec < 1) stop 'Must have at least one receiver' ! allocate vectors allocate(x_rec(nrec),z_rec(nrec),x_rec_lon(nrec),z_rec_lat(nrec)) @@ -1013,7 +1013,7 @@ program wave2d do xmesh = 0.,LENGTH,dx do zmesh = 0.,HEIGHT,dz i = i+1 - if(i > MAX_SR_FAKE) stop 'i > MAX_SR_FAKE so change dx, dz, or MAX_SR_FAKE' + if (i > MAX_SR_FAKE) stop 'i > MAX_SR_FAKE so change dx, dz, or MAX_SR_FAKE' x_recf0(i) = xmesh z_recf0(i) = zmesh enddo @@ -1029,7 +1029,7 @@ program wave2d ! filter target points (utm-mesh) -- update nrecf call station_filter(nrecf, x_recf0, z_recf0, ifilter_recf, STATION_GRID_BUFFER) - if(nrecf < 1) stop 'Must have at least one fake (adjoint) receiver' + if (nrecf < 1) stop 'Must have at least one fake (adjoint) receiver' ! allocate vectors allocate(x_recf(nrecf),z_recf(nrecf),fglob(nrecf)) @@ -1153,7 +1153,7 @@ program wave2d !enddo do i = 1,nmod - if(i <= nmod_str) then + if (i <= nmod_str) then m0_vec(i) = c_glob_syn(i) ! m/s else m0_vec(i) = m_src_syn(i-nmod_str) ! xs, zs, t0 @@ -1169,7 +1169,7 @@ program wave2d !------------------ -if(ISOURCE_LOG) open(91,file=trim(out_dir2)//'source_vector.log',status='unknown') +if (ISOURCE_LOG) open(91,file=trim(out_dir2)//'source_vector.log',status='unknown') itest = 0 !============================================ @@ -1179,8 +1179,8 @@ program wave2d imod = (istep - mod(istep,2))/2 ! index into model number -!!$ if( mod(imod,2) == 0 ) then -!!$ !if(imod <= 1 .or. imod==5 .or. imod==9 .or. imod==13) then +!!$ if ( mod(imod,2) == 0 ) then +!!$ !if (imod <= 1 .or. imod==5 .or. imod==9 .or. imod==13) then !!$ INV_SOURCE = 1 !!$ INV_STRUCT = 0 !!$ else @@ -1191,8 +1191,8 @@ program wave2d irun = irun0 + istep print *,'==============================================================' print *,' istep, imod, irun : ', istep, imod, irun - if(INV_STRUCT==1) print *, ' inverting for structure parameters' - if(INV_SOURCE==1) print *, ' inverting for source parameters' + if (INV_STRUCT==1) print *, ' inverting for structure parameters' + if (INV_SOURCE==1) print *, ' inverting for source parameters' print *,'==============================================================' !enddo @@ -1210,14 +1210,14 @@ program wave2d ! use the reference model or test model (source and structure) ! structure is the top portion; source is the bottom portion - if(itest==0) then + if (itest==0) then c_glob_syn(:) = m0_vec(1:nmod_str) m_src(:) = m0_vec(nmod_str+1:nmod) !m_vel(:) = m0_vel(:) !m_src(:) = m0_src(:) - else if(itest==1) then + else if (itest==1) then c_glob_syn(:) = mt_vec(1:nmod_str) m_src(:) = mt_vec(nmod_str+1:nmod) @@ -1267,7 +1267,7 @@ program wave2d ! get the lat-lon of the TARGET RECEIVERS - if(ISRC_SPACE <= 5) then ! if you do NOT want a point source from the event list + if (ISRC_SPACE <= 5) then ! if you do NOT want a point source from the event list x_src_lon0(:) = 0. ; z_src_lat0(:) = 0. x_src0(:) = 0. ; z_src0(:) = 0. @@ -1349,7 +1349,7 @@ program wave2d do xmesh = xcen-s_radius, xcen+s_radius, dx do zmesh = zcen-s_radius, zcen+s_radius, dx d = sqrt((xmesh - xcen)**2+(zmesh - zcen)**2) - if(d < s_radius) then + if (d < s_radius) then i = i+1 x_src0(i) = xmesh z_src0(i) = zmesh @@ -1369,7 +1369,7 @@ program wave2d ! make sure that there are fewer target points than the max allowed ! (this is not ideal, since you might have a file of points that extend far outside the grid) - if(nsrc > MAX_SR) then + if (nsrc > MAX_SR) then print * print *, ' ISRC_SPACE = ', ISRC_SPACE print *, ' nsrc = ', nsrc @@ -1389,7 +1389,7 @@ program wave2d ! filter target points (utm-mesh) -- update nsrc call station_filter(nsrc, x_src0, z_src0, ifilter_src, SOURCE_GRID_BUFFER) - if(nsrc < 1) stop 'Must have at least one source' + if (nsrc < 1) stop 'Must have at least one source' ! allocate vectors allocate(x_src(nsrc),z_src(nsrc),x_src_lon(nsrc),z_src_lat(nsrc)) @@ -1473,7 +1473,7 @@ program wave2d !!$ ! perturb source location from the previous model !!$ ! this only changes the source if INV_SRC = 1 -!!$ if(istep==0) then ! initial source +!!$ if (istep==0) then ! initial source !!$ !!$ x_src(1) = x_eve(ievent) ! x position, perturbed event !!$ z_src(1) = z_eve(ievent) ! z position, perturbed event @@ -1504,7 +1504,7 @@ program wave2d ! filter target points (utm-mesh) -- update nsrc call station_filter(nsrc, x_src, z_src, ifilter_src, SOURCE_GRID_BUFFER) - if(nsrc /= 1) stop 'Must be a single point source' + if (nsrc /= 1) stop 'Must be a single point source' ! determine the (eta, xi) corresponding to the target points ! this UPDATES x_src, z_src; sglob is the index of the closest gridpoint @@ -1549,7 +1549,7 @@ program wave2d endif ! ISRC_SPACE - if(ISOURCE_LOG) then + if (ISOURCE_LOG) then ! source log file itemp1 = (ievent-1)*3 + 1 itemp2 = (ievent-1)*3 + 2 @@ -1572,9 +1572,9 @@ program wave2d ! source time function FOR DATA AND SYNTHETICS ! source magnitude (same for data and synthetics) - if(NCOMP==3) then + if (NCOMP==3) then f0(1) = 0.0 ; f0(2) = FNORM ; f0(3) = 0.0 - else if(NCOMP==1) then + else if (NCOMP==1) then f0(1) = FNORM else stop 'NCOMP must be 1 or 3' @@ -1666,13 +1666,13 @@ program wave2d file_src_rec = trim(out_dir)//'sr.txt' open(12,file=file_src_rec,status='unknown',iostat=ios) if (ios /= 0) stop 'Error opening out_dir/sr.txt' - if(ISRC_SPACE /= 5) then + if (ISRC_SPACE /= 5) then write(12,'(a,2f12.6,i10)') ('S ', x_lon(sglob(i)), z_lat(sglob(i)), i, i=1,nsrc) else ! finite area source do i=1,nsrc d = sqrt((x(sglob(i)) - xcen)**2+(z(sglob(i)) - zcen)**2) - if( d > s_radius-dh) then ! get outermost sources + if ( d > s_radius-dh) then ! get outermost sources write(12,'(a,2f12.6,i10)') 'S ', x_lon(sglob(i)), z_lat(sglob(i)), i endif enddo @@ -1682,7 +1682,7 @@ program wave2d ! plot phase velocity map with source-receiver geometry and source time function iopt = 3 + idat - if(ISURFACE==1) then + if (ISURFACE==1) then !filename1 = 'get_model.csh' !filename2 = trim(script_dir)//'plot_model.pl' !open(19,file=filename1,status='unknown') @@ -1704,7 +1704,7 @@ program wave2d !----------------------------------------------------- ! write the current models to file - if(ifirst == 1) then + if (ifirst == 1) then ! write phase velocity maps to file (data is always the same) open(unit=18,file=trim(out_dir1)//file_dat_c,status='unknown') @@ -1747,12 +1747,12 @@ program wave2d !========================= ! DATA (forward wavefield) - if(WRITE_STF_F) call write_seismogram(samp_dat, nsrc, trim(out_dir)//'stffor_dat') + if (WRITE_STF_F) call write_seismogram(samp_dat, nsrc, trim(out_dir)//'stffor_dat') ! compute data for misfit kernels allocate(data(NSTEP,NCOMP,nrec)) data(:,:,:) = 0.0 - if(IKER <= 4) then + if (IKER <= 4) then ! set velocity field for the data c_glob(:) = c_glob_dat @@ -1768,7 +1768,7 @@ program wave2d ! write out seismograms at the receivers data_tag = 'dat' - if(WRITE_SEISMO_F) call write_seismogram(data, nrec, trim(out_dir)//data_tag) + if (WRITE_SEISMO_F) call write_seismogram(data, nrec, trim(out_dir)//data_tag) endif !stop 'testing' @@ -1776,7 +1776,7 @@ program wave2d !========================= ! SYNTHETICS (forward wavefield) - if(WRITE_STF_F) call write_seismogram(samp, nsrc, trim(out_dir)//'stffor_syn') + if (WRITE_STF_F) call write_seismogram(samp, nsrc, trim(out_dir)//'stffor_syn') !stop 'testing' @@ -1797,9 +1797,9 @@ program wave2d ! write out seismograms at the receivers syn_tag = 'syn' !syn_tag = 'forward' - if(WRITE_SEISMO_F) call write_seismogram(syn, nrec, trim(out_dir)//syn_tag) + if (WRITE_SEISMO_F) call write_seismogram(syn, nrec, trim(out_dir)//syn_tag) - if(WRITE_SPECTRAL_MAP_F) then + if (WRITE_SPECTRAL_MAP_F) then print *, 'compute and write out forward spectral map ' call write_spectral_map(syn, nrec, rglob, trim(out_dir)//'spectral_forward',WRITE_SPECTRA_F) endif @@ -1839,22 +1839,22 @@ program wave2d ! write out adjoint source time function at the receivers stfadj_tag = 'stfadj' - if(WRITE_STF_A) call write_seismogram(adj_syn, nrec, trim(out_dir)//stfadj_tag) + if (WRITE_STF_A) call write_seismogram(adj_syn, nrec, trim(out_dir)//stfadj_tag) !stop 'testing' ! OUTPUT ASCII FILES --> SAC FILES (make_sac_files.pl) ! (1) data, (2) synthetics, (3) adjoint source time function -!!$ if(WRITE_SEISMO_F) then +!!$ if (WRITE_SEISMO_F) then !!$ filename1 = trim(script_dir)//'make_sac_files.csh' !!$ filename2 = 'make_sac_files.pl' !!$ open(19,file=filename1,status='unknown') -!!$ if(IKER <= 4) write(19,'(7a,f12.6)') trim(script_dir)//trim(filename2),' ', & +!!$ if (IKER <= 4) write(19,'(7a,f12.6)') trim(script_dir)//trim(filename2),' ', & !!$ trim(out_dir),' ', trim(data_tag) ,' ','1', tshift !!$ write(19,'(7a,f12.6)') trim(script_dir)//trim(filename2),' ', & !!$ trim(out_dir),' ', trim(syn_tag) ,' ','1', tshift -!!$ if(WRITE_STF_A) write(19,'(7a,f12.6)') trim(script_dir)//trim(filename2),' ', & +!!$ if (WRITE_STF_A) write(19,'(7a,f12.6)') trim(script_dir)//trim(filename2),' ', & !!$ trim(out_dir),' ', trim(stfadj_tag),' ','1', tshift !!$ close(19) !!$ call system('chmod 755 scripts/make_sac_files.csh ; scripts/make_sac_files.csh') @@ -1903,7 +1903,7 @@ program wave2d ! we always evaluate the kernels for the present model ! we only evaluate the kernel for the test model if itest==1 and POLY_ORDER==3 - if(itest==0 .or. POLY_ORDER==3) then + if (itest==0 .or. POLY_ORDER==3) then print * print *, 'compute the kernel via adjoint wavefield interaction' print * @@ -1955,7 +1955,7 @@ program wave2d deallocate(rho_kernel, mu_kernel, kappa_kernel) ! write out adjoint seismograms at the original sources - if(WRITE_SEISMO_A) call write_seismogram(samp, nsrc, trim(out_dir)//'synadj') + if (WRITE_SEISMO_A) call write_seismogram(samp, nsrc, trim(out_dir)//'synadj') endif @@ -2016,26 +2016,26 @@ program wave2d close(18) deallocate(measure_vec) - if(ISOURCE_LOG) write(91,'(a12,1f18.8)') ' chi(m) : ', chi_val + if (ISOURCE_LOG) write(91,'(a12,1f18.8)') ' chi(m) : ', chi_val ! stopping criterion needs to be better defined (depends on misfit function --- and DT) ! (We needed this for the basic source inversions.) - !if(chi_val <= 0.1 .and. itest==0) stop 'DONE: you have minimized chi(m) to chi(m) <= 0.1' + !if (chi_val <= 0.1 .and. itest==0) stop 'DONE: you have minimized chi(m) to chi(m) <= 0.1' print *, ' Written chi values to file' print *, ' Now we compute the gradient of the misfit function (using the misfit kernel)' !----------------------------------------------------- - ! COMPUTE THE GRADIENT OF THE MISFIT FUNCTION, if the present model is not + ! COMPUTE THE GRADIENT OF THE MISFIT function, if the present model is not ! a test model or if the CG polynomial is a cubic function ! DO NOT smooth kernel for test model if quadratic polynomial is being used - if(itest==0 .or. POLY_ORDER==3) then + if (itest==0 .or. POLY_ORDER==3) then print *, ' Computing the gradient of the misfit function for a given model' gradient(:) = 0. - if(INV_STRUCT == 1) then ! smooth the kernels to remove spurious src-rec effects + if (INV_STRUCT == 1) then ! smooth the kernels to remove spurious src-rec effects ! summed kernel for all events (NGLOB by 1) open(19,file=trim(out_dir1)//'summed_ker.dat',status='unknown') @@ -2059,7 +2059,7 @@ program wave2d dmin = sqrt(LENGTH**2+HEIGHT**2) ! max possible distance do iglob = 1,NGLOB d = sqrt((xtar-x(iglob))**2+(ztar-z(iglob))**2) - if(d < dmin) then + if (d < dmin) then igaus = iglob dmin = d endif @@ -2069,7 +2069,7 @@ program wave2d k_gaus_global_ex(:) = 0. do iglob = 1,NGLOB dist2 = (xcen - x(iglob))**2 + (zcen - z(iglob))**2 - if(dist2 <= dtrsh2) & + if (dist2 <= dtrsh2) & !k_gaus_global_ex(iglob) = (1./(2*PI*sigma**2)) * exp(-dist2 / (2.*sigma**2)) k_gaus_global_ex(iglob) = (4./(PI*gamma**2)) * exp(-4.*dist2 / (gamma**2)) enddo @@ -2085,7 +2085,7 @@ program wave2d k_gaus_global(:) = 0. do i = 1,NGLOB dist2 = (xcen - x(i))**2 + (zcen - z(i))**2 - if(dist2 <= dtrsh2) & + if (dist2 <= dtrsh2) & !k_gaus_global(i) = (1./(2.*PI*sigma**2)) * exp(-dist2 / (2.*sigma**2)) k_gaus_global(i) = (4./(PI*gamma**2)) * exp(-4.*dist2 / (gamma**2)) enddo @@ -2131,7 +2131,7 @@ program wave2d enddo ! write smooth-related functions to file - if(0==1) then + if (0==1) then file_smooth = 'fun_smooth.dat' open(unit=19,file=trim(out_dir1)//file_smooth,status='unknown') do iglob = 1,NGLOB @@ -2155,8 +2155,8 @@ program wave2d ! KEY: scaling parameter for structure for (joint) inversions mfac = 1.0 - if(istep==0) then - if(INV_SOURCE == 1 .and. INV_STRUCT == 1) then + if (istep==0) then + if (INV_SOURCE == 1 .and. INV_STRUCT == 1) then ! scale structure parameters according to source m_scale_str = mfac * sqrt( sum(source_gradient(:)*source_gradient(:)) ) & / sqrt( sum(k_smooth_global(:)*k_smooth_global(:) *sqrt(da(:))*sqrt(da(:)) )) @@ -2172,7 +2172,7 @@ program wave2d print *, ' mfac = ', mfac print *, ' F = ', m_scale_str - if(INV_STRUCT == 1) then + if (INV_STRUCT == 1) then ! KEY: compute gradient in 'irregular block' basis ! (special case of local Lagrange polynomial basis) do iglob = 1,NGLOB @@ -2184,10 +2184,10 @@ program wave2d ! fill the bottom of the model vector with source parameters ! (dx,dy,dt) * nevent - if(INV_SOURCE == 1) gradient(nmod_str+1:nmod) = source_gradient(:) + if (INV_SOURCE == 1) gradient(nmod_str+1:nmod) = source_gradient(:) ! write gradient vector to file - if(0==1) then + if (0==1) then open(unit=19,file=trim(out_dir1)//'gradient_vec.dat',status='unknown') do i = 1,nmod write(19,'(1e20.10)') gradient(i) @@ -2202,7 +2202,7 @@ program wave2d print *, ' Entering CG algorithm to compute new model or test model' - if(itest==0) then ! if the present kernel is for a REAL model + if (itest==0) then ! if the present kernel is for a REAL model chi_k_val = chi_val gk(:) = gradient(:) @@ -2211,7 +2211,7 @@ program wave2d ! looking at perturbations relative to THE LATEST source position m0(:) = 0. - if(INV_STRUCT == 1) then + if (INV_STRUCT == 1) then ! KEY: fractional pert from c0 do iglob = 1,nmod_str @@ -2221,7 +2221,7 @@ program wave2d enddo endif - if(INV_SOURCE == 1) then + if (INV_SOURCE == 1) then ! scaled perturbation from initial source do i = 1,nmod_src m0(nmod_str+i) = (m_src(i) - m_src_syn(i)) / m_scale_src(i) @@ -2229,7 +2229,7 @@ program wave2d endif ! update search direction - if(istep == 0) then + if (istep == 0) then pk(:) = -gk(:) ! initial search direction else @@ -2240,18 +2240,18 @@ program wave2d ! test value for line-search to get test model !istep_switch = 6 - !if(istep < istep_switch) lam_t_val = -2.*chi_k_val / dot_product(gk, pk) ! quadratic extrapolation - !if(istep >= istep_switch) lam_t_val = -chi_k_val / dot_product(gk, pk) ! linear extrapolation + !if (istep < istep_switch) lam_t_val = -2.*chi_k_val / dot_product(gk, pk) ! quadratic extrapolation + !if (istep >= istep_switch) lam_t_val = -chi_k_val / dot_product(gk, pk) ! linear extrapolation lam_t_val = -2.*chi_k_val / dot_product(gk, pk) mt(:) = m0(:) + lam_t_val * pk(:) !mt(:) = m0(:) + lam_t_val * pk(:) / da(:) ! structure only (g = K da) itest = 1 do i=1,nmod - if(i <= nmod_str) then ! structure + if (i <= nmod_str) then ! structure ! get the new (test) structure model in terms of fractional perturbation - if(INV_STRUCT == 0) then + if (INV_STRUCT == 0) then mt_vec(i) = c_glob_syn(i) ! use same structure always else @@ -2262,7 +2262,7 @@ program wave2d else ! source ! get the new source model in terms of (xs, zs, t0) - if(INV_SOURCE == 0) then + if (INV_SOURCE == 0) then !mt_vec(i) = m0_vec(i) ! use same source always mt_vec(i) = m_src_syn(i - nmod_str) @@ -2284,7 +2284,7 @@ program wave2d g0(:) = gk(:) p0(:) = pk(:) - else if(itest==1) then ! if present kernel is for a test model + else if (itest==1) then ! if present kernel is for a test model chi_t_val = chi_val @@ -2295,7 +2295,7 @@ program wave2d yy2 = chi_t_val g1 = dot_product(g0,pk) - if(POLY_ORDER == 3) then + if (POLY_ORDER == 3) then ! use cubic polynomial: six values gives an analytical minimum ! see Matlab scripts cubic_min_4.m and cubic_min.m @@ -2315,9 +2315,9 @@ program wave2d ! get the analytical minimum qfac = Pb**2 - 3.*Pa*Pc; - if(Pa /= 0 .and. qfac >= 0) then + if (Pa /= 0 .and. qfac >= 0) then xmin = (-Pb + sqrt(qfac)) / (3.*Pa) - else if(Pa == 0 .and. Pb /= 0) then + else if (Pa == 0 .and. Pb /= 0) then xmin = -Pc/(2.*Pb) else stop 'check the input polynomial' @@ -2338,7 +2338,7 @@ program wave2d Pc = yy1 - Pa*xx1**2 - Pb*xx1 ! get the analytical minimum (the vertex) - if(Pa /= 0) then + if (Pa /= 0) then xmin = -Pb / (2.*Pa) else stop 'check the input polynomial' @@ -2358,10 +2358,10 @@ program wave2d itest = 0 do i=1,nmod - if(i <= nmod_str) then ! structure + if (i <= nmod_str) then ! structure ! get the new structure model in terms of fractional perturbation - if(INV_STRUCT == 0) then + if (INV_STRUCT == 0) then m0_vec(i) = c_glob_syn(i) ! use same structure always else @@ -2372,7 +2372,7 @@ program wave2d else ! source ! get the new source model in terms of (xs, zs, t0) - if(INV_SOURCE == 0) then + if (INV_SOURCE == 0) then !m0_vec(i) = m0_vec(i) ! use same source always m0_vec(i) = m_src_syn(i - nmod_str) @@ -2396,14 +2396,14 @@ program wave2d ! write updated/test model to file (source + structure) ! write CG vectors to file - if(1==1) then + if (1==1) then open(unit=19,file=trim(out_dir1)//'cg_model_vectors.dat',status='unknown') do i = 1,nmod write(19,'(4e16.6)') m0(i), mt(i), m0_vec(i), mt_vec(i) enddo close(19) endif - if(0==1) then + if (0==1) then open(unit=19,file=trim(out_dir1)//'cg_grad_vectors.dat',status='unknown') do i = 1,nmod write(19,'(5e16.6)') g0(i), gt(i), gk(i), p0(i), pk(i) @@ -2413,10 +2413,10 @@ program wave2d ! exit program if model values are unrealistic ! NOTE: model parameters must be scaled appropriately - if(itest==1) then - if( minval(mt) < -10. .or. maxval(mt) > 10. ) stop 'test model is too extreme' + if (itest==1) then + if ( minval(mt) < -10. .or. maxval(mt) > 10. ) stop 'test model is too extreme' else - if( minval(m0) < -10. .or. maxval(m0) > 10. ) stop 'updated model is too extreme' + if ( minval(m0) < -10. .or. maxval(m0) > 10. ) stop 'updated model is too extreme' endif !==================== @@ -2427,7 +2427,7 @@ program wave2d enddo ! istep !================================== - if(ISOURCE_LOG) close(91) ! source log file + if (ISOURCE_LOG) close(91) ! source log file ! deallocate event and receiver variables @@ -2467,7 +2467,7 @@ program wave2d !!$ call solver(isolver, nsrc, sglob, samp, nrec, rglob, syn) !!$ !!$ ! write out seismograms at the receivers -!!$ if(WRITE_SEISMO_F) call write_seismogram(syn, nrec, trim(out_dir)//'forward') +!!$ if (WRITE_SEISMO_F) call write_seismogram(syn, nrec, trim(out_dir)//'forward') !!$ !!$ print *, 'compute and write out forward spectral map ' !!$ call write_spectral_map(syn, nrec, rglob, trim(out_dir)//'spectral_forward',WRITE_SPECTRA_F) @@ -2489,7 +2489,7 @@ program wave2d !!$ call solver(isolver, nrecf, fglob, samp, nrec, rglob, syn) !!$ !!$ ! write out adjoint seismograms at the fake receivers -!!$ if(WRITE_SEISMO_A) call write_seismogram(samp, nrecf, trim(out_dir)//'adjoint') +!!$ if (WRITE_SEISMO_A) call write_seismogram(samp, nrecf, trim(out_dir)//'adjoint') !!$ !!$ print *, 'compute and write out adjoint spectral map ' !!$ call write_spectral_map(samp, nrecf, fglob, trim(out_dir)//'spectral_adjoint',WRITE_SPECTRA_A) @@ -2505,7 +2505,7 @@ program wave2d !!$ call solver(isolver, nsrc, sglob, samp, nrec, rglob, syn) !!$ !!$ ! write out adjoint seismograms at the original sources -!!$ if(WRITE_SEISMO_A) call write_seismogram(samp, nsrc, trim(out_dir)//'adjoint') +!!$ if (WRITE_SEISMO_A) call write_seismogram(samp, nsrc, trim(out_dir)//'adjoint') !================================== diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d_cmap.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d_cmap.f90 index 07eb3d608..1c3db490e 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d_cmap.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d_cmap.f90 @@ -122,7 +122,7 @@ program wave2d_cmap !!$ ! regular mesh or SPECFEM mesh !!$ i_regular = 0 !!$ -!!$ if(i_regular==1) then +!!$ if (i_regular==1) then !!$ !!$ ! enter new uniform mesh !!$ dx = 40.0d+03 @@ -144,7 +144,7 @@ program wave2d_cmap !!$ allocate(c_glob9(ntemp),c_glob_syn9(ntemp),c_glob_dat9(ntemp)) !!$ allocate(da9(ntemp)) !!$ -!!$ if(i_regular==1) then +!!$ if (i_regular==1) then !!$ !!$ k = 0 !!$ do xtemp = -fac,LENGTH+fac,dx @@ -233,7 +233,7 @@ program wave2d_cmap dmin = sqrt(LENGTH**2+HEIGHT**2) ! max possible distance do iglob = 1,NGLOB d = sqrt((xtar-x(iglob))**2+(ztar-z(iglob))**2) - if(d < dmin) then + if (d < dmin) then igaus = iglob dmin = d endif @@ -243,7 +243,7 @@ program wave2d_cmap k_gaus_global_ex(:) = 0. do iglob = 1,NGLOB dist2 = (xcen - x(iglob))**2 + (zcen - z(iglob))**2 - if(dist2 <= dtrsh2) & + if (dist2 <= dtrsh2) & k_gaus_global_ex(iglob) = (1./(2*PI*SIGMA**2)) * exp(-dist2 / (2.*SIGMA**2)) enddo @@ -257,7 +257,7 @@ program wave2d_cmap k_gaus_global(:) = 0. do i = 1,NGLOB dist2 = (xcen - x(i))**2 + (zcen - z(i))**2 - if(dist2 <= dtrsh2) & + if (dist2 <= dtrsh2) & k_gaus_global(i) = (1./(2.*PI*SIGMA**2)) * exp(-dist2 / (2.*SIGMA**2)) enddo diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d_define_der_matrices.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d_define_der_matrices.f90 index 6612f78d9..6b5cb6d9b 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d_define_der_matrices.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d_define_der_matrices.f90 @@ -35,8 +35,8 @@ subroutine define_derivative_matrices(xigll,zigll,wxgll,wzgll,hprime_xx,hprime_z call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA) ! if number of points is odd, the middle abscissa is exactly zero - if(mod(NGLLX,2) /= 0) xigll((NGLLX-1)/2+1) = 0.d0 - if(mod(NGLLZ,2) /= 0) zigll((NGLLZ-1)/2+1) = 0.d0 + if (mod(NGLLX,2) /= 0) xigll((NGLLX-1)/2+1) = 0.d0 + if (mod(NGLLZ,2) /= 0) zigll((NGLLZ-1)/2+1) = 0.d0 ! calculate derivatives of the Lagrange polynomials ! and precalculate some products in double precision diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d_solver.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d_solver.f90 index f63b8cef3..011c19f37 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d_solver.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d_solver.f90 @@ -112,7 +112,7 @@ subroutine mesher ! estimate the time step dh = HEIGHT/dble((NGLLZ-1)*NEZ) - if(dh > LENGTH/dble((NGLLX-1)*NEX)) dh = LENGTH/dble((NGLLX-1)*NEX) + if (dh > LENGTH/dble((NGLLX-1)*NEX)) dh = LENGTH/dble((NGLLX-1)*NEX) c = sqrt((INCOMPRESSIBILITY+FOUR_THIRDS*RIGIDITY)/DENSITY) time_step = 0.2*dh/c print * @@ -132,13 +132,13 @@ subroutine set_model_property() do iglob = 1,NGLOB rho_global(iglob) = DENSITY kappa_global(iglob) = INCOMPRESSIBILITY - if(ISURFACE==0) then + if (ISURFACE==0) then mu_global(iglob) = RIGIDITY else ! KEY: this means that the S velocity will be the surface wave phase velocity (m/s) mu_global(iglob) = DENSITY*(c_glob(iglob))**2 - !if(ihomo==1) mu_global(iglob) = DENSITY*c0**2 - !if(ihomo==0) mu_global(iglob) = DENSITY*(c_glob(iglob))**2 + !if (ihomo==1) mu_global(iglob) = DENSITY*c0**2 + !if (ihomo==0) mu_global(iglob) = DENSITY*(c_glob(iglob))**2 endif enddo @@ -160,7 +160,7 @@ subroutine set_model_property() !!$ iglob = ibool(NGLLX/2,NGLLZ/2,ispec) !!$ do j = 1,NGLLZ !!$ do i = 1,NGLLX -!!$ if(z(iglob) >= 0) then +!!$ if (z(iglob) >= 0) then !!$ ! crust !!$ rho(i,j,ispec) = DENSITY !!$ kappa(i,j,ispec) = INCOMPRESSIBILITY @@ -239,8 +239,8 @@ subroutine solver(solver_type, nsrc, sglob, ispec_src, hxis_store, hgammas_store !-------------------------------------- - if(NCOMP==3) fm = '(9e12.3)' - if(NCOMP==1) fm = '(3e12.3)' + if (NCOMP==3) fm = '(9e12.3)' + if (NCOMP==1) fm = '(3e12.3)' ! test of input arguments if (solver_type /= 1 .and. solver_type /= 2 .and. solver_type /= 3) then @@ -280,7 +280,7 @@ subroutine solver(solver_type, nsrc, sglob, ispec_src, hxis_store, hgammas_store ! gridpoints per wavelength estimation print * print *, 'space step (km):', sngl(dh/1000.) - if(ISURFACE) then + if (ISURFACE) then print *, 'wavelength-min (km):', sngl(2*hdur*cmin/1000.) print *, 'wavelength-max (km):', sngl(2*hdur*cmax/1000.) print *, 'number of gridpoints per wavelength for S:' @@ -359,7 +359,7 @@ subroutine solver(solver_type, nsrc, sglob, ispec_src, hxis_store, hgammas_store endif enddo - if(NCOMP==1) then ! SH, or surface waves only + if (NCOMP==1) then ! SH, or surface waves only ! ! INTEGRATION OVER SPECTRAL ELEMENTS @@ -408,7 +408,7 @@ subroutine solver(solver_type, nsrc, sglob, ispec_src, hxis_store, hgammas_store dsydzl = tempy1l*dxidzl + tempy2l*dgammadzl ! save spatial gradient for (point) source perturbations - if(solver_type == 3 .and. ispec == ispec_src(1)) then + if (solver_type == 3 .and. ispec == ispec_src(1)) then displ_grad(i,j,1) = dsydxl displ_grad(i,j,2) = dsydzl endif @@ -509,13 +509,13 @@ subroutine solver(solver_type, nsrc, sglob, ispec_src, hxis_store, hgammas_store ! sections need to be adjusted as well do ibb = 1,NABSORB ! index of grid boundary - if(ibb == 1) then + if (ibb == 1) then i = 1 - else if(ibb == 2) then + else if (ibb == 2) then i = NGLLX - else if(ibb == 3) then + else if (ibb == 3) then i = 1 - else if(ibb == 4) then + else if (ibb == 4) then i = NGLLZ endif @@ -937,7 +937,7 @@ subroutine solver(solver_type, nsrc, sglob, ispec_src, hxis_store, hgammas_store do i = 1,NGLOB accel(:,i) = accel(:,i)/mass_global(i) - if(solver_type == 3) & + if (solver_type == 3) & b_accel(:,i) = b_accel(:,i)/mass_global(i) enddo @@ -966,7 +966,7 @@ subroutine solver(solver_type, nsrc, sglob, ispec_src, hxis_store, hgammas_store ! equivalent to using closest gridpoint -- OLD METHOD !hlagrange = 0. - !if(iglob == rglob(irec)) hlagrange = 1. + !if (iglob == rglob(irec)) hlagrange = 1. ramp(itime,:,irec) = ramp(itime,:,irec) + displ(:,iglob)*hlagrange enddo @@ -1019,7 +1019,7 @@ subroutine solver(solver_type, nsrc, sglob, ispec_src, hxis_store, hgammas_store enddo ! isrc - if(solver_type==3) then + if (solver_type==3) then ! CALCULATE SIX KERNELS -- notice the time integration do iglob = 1, NGLOB @@ -1102,7 +1102,7 @@ subroutine solver(solver_type, nsrc, sglob, ispec_src, hxis_store, hgammas_store !!xtemp = x(iglob)/LENGTH ; ztemp = z(iglob)/LENGTH !xtemp = x(iglob)/1000. ; ztemp = z(iglob)/1000. - if(WRITE_SNAPSHOTS) then ! wavefield snapshots + if (WRITE_SNAPSHOTS) then ! wavefield snapshots open(unit=11, file=trim(filename1), status='unknown', iostat=ios) if (ios /= 0) stop 'Error writing snapshot to disk' do iglob = 1, NGLOB @@ -1112,7 +1112,7 @@ subroutine solver(solver_type, nsrc, sglob, ispec_src, hxis_store, hgammas_store close(11) endif - if(WRITE_KERNELS) then ! kernel snapshots + if (WRITE_KERNELS) then ! kernel snapshots if (solver_type == 3) then open(unit=11, file=trim(filename2), status='unknown', iostat=ios) if (ios /= 0) stop 'Error writing snapshot to disk' @@ -1129,7 +1129,7 @@ subroutine solver(solver_type, nsrc, sglob, ispec_src, hxis_store, hgammas_store xtemp = x_lon(iglob) ; ztemp = z_lat(iglob) - if(ISURFACE==0) then + if (ISURFACE==0) then ! six kernels into two files write(11,'(5e16.6)') sngl(xtemp), sngl(ztemp), sngl(rho_kernel(iglob)), & sngl(mu_kernel(iglob)), sngl(kappa_kernel(iglob)) @@ -1151,7 +1151,7 @@ subroutine solver(solver_type, nsrc, sglob, ispec_src, hxis_store, hgammas_store enddo ! end time loop - if(solver_type == 3) deallocate(stf_for) + if (solver_type == 3) deallocate(stf_for) end subroutine solver !--------------------------------------------- diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d_sub.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d_sub.f90 index 4b6540bfa..e91f5718c 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d_sub.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d_sub.f90 @@ -84,13 +84,13 @@ subroutine get_source_time_function(origin_time,stf_vec,ti) fgaus = 1.d-8 ! fraction of amplitude at edge of Gaussian dgaus = sqrt(-log(fgaus)) / alpha - if(ISRC_TIME==1) then ! Ricker + if (ISRC_TIME==1) then ! Ricker amp = -2.*(alpha**3)/dsqrt(PI) - else if(ISRC_TIME==2) then ! Gaussian + else if (ISRC_TIME==2) then ! Gaussian amp = alpha/dsqrt(PI) - else if(ISRC_TIME==3) then ! truncated sine + else if (ISRC_TIME==3) then ! truncated sine cyc = 3 per = 2.*hdur !t1 = -0.50*per @@ -98,11 +98,11 @@ subroutine get_source_time_function(origin_time,stf_vec,ti) t2 = t1 + per*dble(cyc) amp = alpha**2*dsqrt(2./PI)*exp(-0.5d0) - else if(ISRC_TIME==4) then ! sine + else if (ISRC_TIME==4) then ! sine per = 2.*hdur amp = alpha**2*dsqrt(2./PI)*exp(-0.5d0) -!!$ else if(ISRC_TIME==5) then ! plane wave field +!!$ else if (ISRC_TIME==5) then ! plane wave field !!$ !!$ amp = alpha**2*dsqrt(2./PI)*exp(-0.5d0) ! amplitude !!$ az = 25.*PI/180. ! azimuth of vector (from north) @@ -138,39 +138,39 @@ subroutine get_source_time_function(origin_time,stf_vec,ti) t = ti(itime) - origin_time ! time shift - if(ISRC_TIME==1) then + if (ISRC_TIME==1) then ! d/dt[Gaussian] wavelet - if(t >= -dgaus .and. t <= dgaus) then + if (t >= -dgaus .and. t <= dgaus) then stf = amp*t*exp(-alpha*alpha*t*t) else stf = 0. endif - else if(ISRC_TIME==2) then + else if (ISRC_TIME==2) then ! Error function ! source_time_function = 0.5d0*(1.0d0+erf(decay_rate*t/hdur)) ! Gaussian (this one causes static offset at stations) - if(t >= -dgaus .and. t <= dgaus) then + if (t >= -dgaus .and. t <= dgaus) then stf = amp*exp(-alpha*alpha*t*t) else stf = 0. endif - else if(ISRC_TIME==3) then + else if (ISRC_TIME==3) then ! truncated sine function (duration is cyc*per seconds) - if(t >= t1 .and. t <= t2) then + if (t >= t1 .and. t <= t2) then stf = amp*sin(2*PI*(t-t1)/per) else stf = 0. endif - else if(ISRC_TIME==4) then + else if (ISRC_TIME==4) then ! sine function stf = amp*sin(2*PI*t/per) !stf = amp/2.*sin(2*PI*t/per) + amp/2.*sin(2*PI*t/(1.1*per)) - !else if(ISRC_TIME==5) then + !else if (ISRC_TIME==5) then ! ! plane wavefield, dependant on source position ! tmp = t - d_vec(i)/c_source ! !stf = amp*sin( 2*PI/per*tmp ) @@ -186,7 +186,7 @@ subroutine get_source_time_function(origin_time,stf_vec,ti) ! taper time series ! DO WE WANT TO SIMPLY DETREND THE TIME SERIES? - if(SRC_TAPER) call taper_series(stf_vec(:),NSTEP) + if (SRC_TAPER) call taper_series(stf_vec(:),NSTEP) end subroutine get_source_time_function @@ -231,7 +231,7 @@ subroutine write_snapshot(disp, filename) open(unit = 11, file = trim(filename), status = 'unknown',iostat=ios) if (ios /= 0) stop 'Error writing snapshot to disk' do iglob = 1, NGLOB - if(NCOMP==3) then + if (NCOMP==3) then write(11,'(5e12.3)') x(iglob)/LENGTH, z(iglob)/LENGTH, & sngl(disp(1,iglob)),sngl(disp(2,iglob)),sngl(disp(3,iglob)) else @@ -348,7 +348,7 @@ subroutine write_spectral_map(seis, nrec, rglob, seis_name, write_spectra) ! specify input time series in(:) = seis(:,icomp,irec) - if(0==1) then + if (0==1) then ! write input data to file write(filename,'(a,a,i5.5,a,i1.1)') trim(seis_name), '_in_', irec, '_', icomp open(unit=10, file=filename, status='unknown', iostat=ios) @@ -361,7 +361,7 @@ subroutine write_spectral_map(seis, nrec, rglob, seis_name, write_spectra) call dfftw_execute(plan) - if(write_spectra) then + if (write_spectra) then write(filename2,'(a,a,i5.5,a,i1.1)') trim(seis_name), '_', irec, '_', icomp open(unit=12, file=filename2, status='unknown', iostat=ios) if (ios /= 0) stop 'Error opening seismogram spectra to write' @@ -378,14 +378,14 @@ subroutine write_spectral_map(seis, nrec, rglob, seis_name, write_spectra) !ph_val = atan2(im,re) ! if within the frequency band - if(w >= wmin_win .and. w <= wmax_win) abs_int = abs_int + abs_val + if (w >= wmin_win .and. w <= wmax_win) abs_int = abs_int + abs_val - if(write_spectra) write(12,'(2e16.6)') w, abs_val - !if(write_spectra.and.w/=0.) write(12,'(2e16.6)') (2*PI)/w, abs_val + if (write_spectra) write(12,'(2e16.6)') w, abs_val + !if (write_spectra.and.w/=0.) write(12,'(2e16.6)') (2*PI)/w, abs_val enddo - if(write_spectra) close(12) + if (write_spectra) close(12) - if(0==1) then + if (0==1) then write(*,'(a,3f12.4)') ' T, s (min/0/max) :', (2*PI)/wmax_win , 2*hdur , (2*PI)/wmin_win write(*,'(a,3f12.4)') ' f, Hz (min/0/max) :', wmin_win/(2*PI) , 1/(2*hdur) , wmax_win/(2*PI) write(*,'(a,3f12.4)') ' w, rad/s (min/0/max) :', wmin_win , 2*PI/(2*hdur) , wmax_win @@ -495,7 +495,7 @@ subroutine make_adjoint_source(nrec, syn, tstart, tend, adj_syn, data) !--------------------------- ! calculate velocity and acceleration from syn (traveltime adjoint source only) - if(IKER >= 1) then + if (IKER >= 1) then do itime = 2, NSTEP-1 syn_veloc(itime,:,irec) = (syn(itime+1,:,irec) - syn(itime-1,:,irec)) / (2 * DT) enddo @@ -513,18 +513,18 @@ subroutine make_adjoint_source(nrec, syn, tstart, tend, adj_syn, data) do i = 1,NCOMP - if(IKER==0) then ! waveform + if (IKER==0) then ! waveform adj_syn(:,i,irec) = ( syn(:,i,irec) - data(:,i,irec) ) * time_window(:) - else if(IKER==5) then ! traveltime + else if (IKER==5) then ! traveltime ! minus sign is shifted from norm to adj_syn, in comparison with Tromp et al (2005) ! thus, norm is ensured to be POSITIVE (N > 0) norm = -DT * sum( time_window(:) * syn(:,i,irec) * syn_accel(:,i,irec) ) if (abs(norm) > EPS) adj_syn(:,i,irec) = -syn_veloc(:,i,irec) * time_window(:) / norm - else if(IKER==6) then ! amplitude + else if (IKER==6) then ! amplitude ! norm is ensured to be POSITIVE (M > 0) norm = DT * sum( time_window(:) * syn(:,i,irec) * syn(:,i,irec) ) diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d_sub2.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d_sub2.f90 index 9f1baef5a..5fd6a72da 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d_sub2.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d_sub2.f90 @@ -65,11 +65,11 @@ subroutine locate_targets(nrec, x_target, z_target, & dist = sqrt((x_target(irec) - x(iglob))**2 + (z_target(irec) - z(iglob))**2) ! keep this point if it is closer to the receiver - if(dist < dmin) then + if (dist < dmin) then dmin = dist dmin_selected_rec(irec) = dmin iglob_selected_rec(irec) = iglob ! closest gridpoint - if(i_xi_gamma) then + if (i_xi_gamma) then ispec_selected_rec(irec) = ispec ix_initial_guess(irec) = i iz_initial_guess(irec) = j @@ -92,7 +92,7 @@ subroutine locate_targets(nrec, x_target, z_target, & ! **************************************** ! if the (xi, gamma) are desired - if(i_xi_gamma) then + if (i_xi_gamma) then do irec = 1,nrec @@ -108,16 +108,16 @@ subroutine locate_targets(nrec, x_target, z_target, & !!$ ! We could also access the vectors x1,x2,z1,z2 instead. !!$ do ia = 1,NGNOD2D ! (NGNOD2D = 4) !!$ -!!$ if(ia==1) then +!!$ if (ia==1) then !!$ iax = 1 !!$ iaz = 1 -!!$ else if(ia==2) then +!!$ else if (ia==2) then !!$ iax = NGLLX !!$ iaz = 1 -!!$ else if(ia==3) then +!!$ else if (ia==3) then !!$ iax = NGLLX !!$ iaz = NGLLZ -!!$ else if(ia==4) then +!!$ else if (ia==4) then !!$ iax = 1 !!$ iaz = NGLLZ !!$ endif @@ -188,9 +188,9 @@ subroutine locate_targets(nrec, x_target, z_target, & ! display information do irec=1,nrec - if(final_distance(irec) == HUGEVAL) stop 'error locating receiver' + if (final_distance(irec) == HUGEVAL) stop 'error locating receiver' - if(0==1) then + if (0==1) then print * print *, 'target point # ', irec write(*,'(a,1f18.8)') ' target x (km) : ', x_target(irec)/1000. @@ -211,7 +211,7 @@ subroutine locate_targets(nrec, x_target, z_target, & ! add warning if estimate is poor ! (usually means receiver outside the mesh given by the user) - if(final_distance(irec) > 5.) then + if (final_distance(irec) > 5.) then print *, 'station # ',irec print *, '*******************************************************' print *, '***** WARNING: receiver location estimate is poor *****' @@ -276,7 +276,7 @@ subroutine recompute_jacobian_2d(ispec, xi, gamma, xtemp, ztemp, xix, xiz, gamma xtemp = 0.5*(1.- xi)*x1(ispec) + 0.5*(1.+ xi)*x2(ispec) ztemp = 0.5*(1.- gamma)*z1(ispec) + 0.5*(1.+gamma)*z2(ispec) - if(jacob <= 0.) stop '2D Jacobian undefined' + if (jacob <= 0.) stop '2D Jacobian undefined' end subroutine recompute_jacobian_2d @@ -302,7 +302,7 @@ subroutine lagrange_poly(xi,NGLL,xigll,h,hprime) prod1 = 1.0 prod2 = 1.0 do i=1,NGLL - if(i /= dgr) then + if (i /= dgr) then prod1 = prod1*(xi-xigll(i)) prod2 = prod2*(xigll(dgr)-xigll(i)) endif @@ -311,10 +311,10 @@ subroutine lagrange_poly(xi,NGLL,xigll,h,hprime) hprime(dgr)=0.0 do i=1,NGLL - if(i /= dgr) then + if (i /= dgr) then prod1=1.0 do j=1,NGLL - if(j /= dgr .and. j /= i) prod1 = prod1*(xi-xigll(j)) + if (j /= dgr .and. j /= i) prod1 = prod1*(xi-xigll(j)) enddo hprime(dgr) = hprime(dgr)+prod1 endif @@ -380,14 +380,14 @@ subroutine set_glob(nrec, x_rec, z_rec, rglob) print *, nrec,' input target points into set_glob.f90' - if(nrec/=0) then + if (nrec/=0) then ! find the closest gridpoint to the target point do irec = 1, nrec dmin = sqrt(LENGTH**2+HEIGHT**2) ! max possible distance do iglob = 1,NGLOB d = sqrt((x_rec(irec)-x(iglob))**2+(z_rec(irec)-z(iglob))**2) - if(d < dmin) then + if (d < dmin) then dmin = d rglob(irec) = iglob endif @@ -402,9 +402,9 @@ subroutine set_glob(nrec, x_rec, z_rec, rglob) itemp = rglob(i) iflag = 0 do j = 1,i - if(rglobtemp(j) == itemp) iflag = 1 + if (rglobtemp(j) == itemp) iflag = 1 enddo - if(iflag==0) then + if (iflag==0) then k = k+1 rglobtemp(k) = itemp endif @@ -423,7 +423,7 @@ subroutine set_glob(nrec, x_rec, z_rec, rglob) !!$ do i = 1,NGLLX !!$ iglob = ibool(i,j,ispec) !!$ d = sqrt((x_rec(irec)-x(iglob))**2+(z_rec(irec)-z(iglob))**2) -!!$ if(d < d_min_rec) then +!!$ if (d < d_min_rec) then !!$ d_min_rec = d !!$ rglob(irec) = ibool(i,j,ispec) !!$ endif @@ -470,7 +470,7 @@ subroutine station_filter(nrec, x_rec, z_rec, ifilter, dmin_trsh) ztar = z_rec(irec) ! if target point is not near grid boundary - if (xtar >= 0.+dmin_trsh & + if (xtar >= 0.+dmin_trsh & .and. xtar <= LENGTH-dmin_trsh & .and. ztar >= 0.+dmin_trsh & .and. ztar <= HEIGHT-dmin_trsh) then @@ -485,7 +485,7 @@ subroutine station_filter(nrec, x_rec, z_rec, ifilter, dmin_trsh) !do i=1,ncoast ! ! distance from target point to coastal points ! d = sqrt((xtar-coast_x(i))**2+(ztar-coast_z(i))**2) - ! if(d < dmin) then + ! if (d < dmin) then ! dmin = d ! endif !enddo @@ -509,7 +509,7 @@ subroutine station_filter(nrec, x_rec, z_rec, ifilter, dmin_trsh) !!$ j = 0 !!$ do irec = 1, nrec !!$ d = sqrt((x(rglob(irec)) - xcen)**2+(z(rglob(irec)) - zcen)**2) -!!$ if(d > r) then +!!$ if (d > r) then !!$ j = j+1 !!$ rglob(j) = rglob(irec) !!$ endif @@ -645,7 +645,7 @@ subroutine utm_geo(rlon,rlat,rx,ry,UTM_PROJECTION_ZONE,iway) !--------------------------------------------------- - if(SUPPRESS_UTM_PROJECTION) then + if (SUPPRESS_UTM_PROJECTION) then if (iway == ILONGLAT2UTM) then rx = rlon ry = rlat diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d_sub3.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d_sub3.f90 index 6515b79a0..ec55246ba 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d_sub3.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/gji_paper/codes_18_06Aug2006/wave2d_sub3.f90 @@ -132,9 +132,9 @@ subroutine mtm_adj(ipick, ievent, nrec, syn, tstart, tend, adj_syn, data) do i = n_left, n_right, 1 cc = 0 do j = 1, nlen - if((j+i) > 1 .and. (j+i) < nlen) cc = cc + dzr_win(j) * dzr2_win(j+i) + if ((j+i) > 1 .and. (j+i) < nlen) cc = cc + dzr_win(j) * dzr2_win(j+i) enddo - if( cc > cc_max) then + if ( cc > cc_max) then cc_max = cc ishift = i endif @@ -143,13 +143,13 @@ subroutine mtm_adj(ipick, ievent, nrec, syn, tstart, tend, adj_syn, data) !=================================================== ! if you want a MTM measurement, then go here - if(IKER==3 .or. IKER==4) then + if (IKER==3 .or. IKER==4) then ! apply time shift to observed seismogram write(*,*) 'shift obs seismogram by ', tshift_xc, 'seconds, irec = ', irec do i = 1, nlen dzr3_win(i) = 0 - if( (ishift+i) > 1 .and. (ishift+i) < nlen ) dzr3_win(i) = dzr2_win(i+ishift) + if ( (ishift+i) > 1 .and. (ishift+i) < nlen ) dzr3_win(i) = dzr2_win(i+ishift) dzr30_win(i) = dzr3_win(i) enddo @@ -211,11 +211,11 @@ subroutine mtm_adj(ipick, ievent, nrec, syn, tstart, tend, adj_syn, data) ampmax = 0 ampmax_unw = 0 do i = 1, fnum - if( abs(wseis(i)) > ampmax) then + if ( abs(wseis(i)) > ampmax) then ampmax = abs(wseis(i)) i_amp_max = i endif - if( abs(wseis1(i)) > ampmax_unw) then + if ( abs(wseis1(i)) > ampmax_unw) then ampmax_unw = abs(wseis1(i)) i_amp_max_unw = i endif @@ -237,15 +237,15 @@ subroutine mtm_adj(ipick, ievent, nrec, syn, tstart, tend, adj_syn, data) bot_mtm(i) = bot_mtm(i) + wseis(i) * conjg(wseis(i)) ! calculate transfer function for single taper measurement using water level - if(abs(wseis(i)) > abs(wtr_use)) trans(i) = wseis3(i) / wseis(i) - if(abs(wseis(i)) <= abs(wtr_use)) trans(i) = wseis3(i) / (wseis(i)+wtr_use) + if (abs(wseis(i)) > abs(wtr_use)) trans(i) = wseis3(i) / wseis(i) + if (abs(wseis(i)) <= abs(wtr_use)) trans(i) = wseis3(i) / (wseis(i)+wtr_use) ! determine i_right values using the power in the un-tapered synthetic - if(abs(wseis1(i)) <= abs(wtr_use_unw) .and. i_right_stop == 0 .and. i > i_amp_max_unw) then + if (abs(wseis1(i)) <= abs(wtr_use_unw) .and. i_right_stop == 0 .and. i > i_amp_max_unw) then i_right_stop = 1 i_right = i endif - if(abs(wseis1(i)) >= 10*abs(wtr_use_unw) .and. i_right_stop == 1 .and. i > i_amp_max_unw) then + if (abs(wseis1(i)) >= 10*abs(wtr_use_unw) .and. i_right_stop == 1 .and. i > i_amp_max_unw) then i_right_stop = 0 i_right = i endif @@ -272,7 +272,7 @@ subroutine mtm_adj(ipick, ievent, nrec, syn, tstart, tend, adj_syn, data) ! find water level for multi taper measurement ampmax = 0 do i = 1, fnum - if( abs(bot_mtm(i)) > ampmax) then + if ( abs(bot_mtm(i)) > ampmax) then ampmax = abs(bot_mtm(i)) i_amp_max = i endif @@ -281,8 +281,8 @@ subroutine mtm_adj(ipick, ievent, nrec, syn, tstart, tend, adj_syn, data) ! calculate transfer function using water level do i = 1, fnum - if(abs(bot_mtm(i)) > abs(wtr_use)) trans_mtm(i) = top_mtm(i) / bot_mtm(i) - if(abs(bot_mtm(i)) <= abs(wtr_use)) trans_mtm(i) = top_mtm(i) / (bot_mtm(i)+wtr_use) + if (abs(bot_mtm(i)) > abs(wtr_use)) trans_mtm(i) = top_mtm(i) / bot_mtm(i) + if (abs(bot_mtm(i)) <= abs(wtr_use)) trans_mtm(i) = top_mtm(i) / (bot_mtm(i)+wtr_use) enddo !======================================================= @@ -367,7 +367,7 @@ subroutine mtm_adj(ipick, ievent, nrec, syn, tstart, tend, adj_syn, data) ! definition of Dahlen and Baig (2002), Eq. 3,17,18 : dlnA = Aobs/Asyn - 1 dlna = sqrt( (DT * sum( datt(:) * datt(:) )) / (DT * sum( synt(:) * synt(:) )) ) - 1. - if(0==1) then + if (0==1) then print * print *, 'cross-correlation measurments:' print *, ' dT = ', tshift_xc @@ -378,7 +378,7 @@ subroutine mtm_adj(ipick, ievent, nrec, syn, tstart, tend, adj_syn, data) endif ! additional files for checking (measure_socal_adj.m) - if(0==1) then + if (0==1) then ! time domain : time, data-disp, syn-disp, syn-vel, syn-accel open(29,file='syn_time.dat') do i = 1,nlen @@ -398,7 +398,7 @@ subroutine mtm_adj(ipick, ievent, nrec, syn, tstart, tend, adj_syn, data) ! create MTM adjoint sources !================================================================== - if(IKER==3 .or. IKER==4) then + if (IKER==3 .or. IKER==4) then pw_adj(:,:) = 0. ; qw_adj(:,:) = 0. pt_adj(:,:) = 0. ; qt_adj(:,:) = 0. @@ -517,62 +517,62 @@ subroutine mtm_adj(ipick, ievent, nrec, syn, tstart, tend, adj_syn, data) i1 = istart - 1 + i - if(ipick==0) then + if (ipick==0) then adj_syn(i1,icomp,irec) = ( syn(i1,icomp,irec) - data(i1,icomp,irec) ) * time_window(i) * meas_pert - else if(ipick==1) then + else if (ipick==1) then ! meas_pert = 1.0 for most runs adj_syn(i1,icomp,irec) = -tshift_xc * ft_bar_t(i) * time_window(i) * meas_pert - else if(ipick==2) then + else if (ipick==2) then adj_syn(i1,icomp,irec) = -dlna * fa_bar_t(i) * time_window(i) * meas_pert - else if(ipick==3) then + else if (ipick==3) then adj_syn(i1,icomp,irec) = fp(i) * time_window(i) - else if(ipick==4) then + else if (ipick==4) then adj_syn(i1,icomp,irec) = fq(i) * time_window(i) - else if(ipick==5) then + else if (ipick==5) then adj_syn(i1,icomp,irec) = ft_bar_t(i) * time_window(i) - else if(ipick==6) then + else if (ipick==6) then adj_syn(i1,icomp,irec) = fa_bar_t(i) * time_window(i) endif enddo - ! (1) COMPUTE MISFIT FUNCTION (currently only for waveform, xc-tt, xc-lnA) + ! (1) COMPUTE MISFIT function (currently only for waveform, xc-tt, xc-lnA) ! (2) COMPUTE MEASUREMENT VECTOR imeasure = imeasure + 1 ! global counter variable - if(ipick==0) then + if (ipick==0) then chi(ievent,irec,icomp,1) = 0.5 * sum( adj_syn(:,icomp,irec)**2 ) * DT measure_vec(imeasure) = chi(ievent,irec,icomp,1) - else if(ipick==1) then + else if (ipick==1) then chi(ievent,irec,icomp,1) = 0.5 * (tshift_xc * meas_pert)**2 measure_vec(imeasure) = tshift_xc * meas_pert - else if(ipick==2) then + else if (ipick==2) then chi(ievent,irec,icomp,1) = 0.5 * (dlna * meas_pert)**2 measure_vec(imeasure) = dlna * meas_pert - else if(ipick==3) then + else if (ipick==3) then chi(ievent,irec,icomp,1) = 0. measure_vec(imeasure) = 0. - else if(ipick==4) then + else if (ipick==4) then chi(ievent,irec,icomp,1) = 0. measure_vec(imeasure) = 0. - else if(ipick==5) then + else if (ipick==5) then chi(ievent,irec,icomp,1) = 0. measure_vec(imeasure) = 0. - else if(ipick==6) then + else if (ipick==6) then chi(ievent,irec,icomp,1) = 0. measure_vec(imeasure) = 0. @@ -601,7 +601,7 @@ subroutine clogc(n,xi,zzign,dt) integer :: l,iblock,nblock,i,lbhalf,j,lx zign=zzign - if(zign >= 0.) then + if (zign >= 0.) then zign=1. else zign=-1. @@ -629,21 +629,21 @@ subroutine clogc(n,xi,zzign,dt) 2 continue do 3 i=2,n ii=i - if(k < m(i)) go to 4 + if (k < m(i)) goto 4 3 k=k-m(i) 4 k=k+m(ii) k=0 do 7 j=1,lx - if(k < j) go to 5 + if (k < j) goto 5 hold=xi(j) xi(j)=xi(k+1) xi(k+1)=hold 5 do 6 i=1,n ii=i - if(k < m(i)) go to 7 + if (k < m(i)) goto 7 6 k=k-m(i) 7 k=k+m(ii) - if(zign > 0.) go to 9 + if (zign > 0.) goto 9 flx=flx*dt do 8 i=1,lx 8 xi(i)=xi(i)/flx @@ -713,16 +713,16 @@ subroutine remo(ny,nm,nd) data m/0,31,59,90,120,151,181,212,243,273,304,334/ integer :: ny, nm, nd, mm - if(.not.(nm==1))goto 23220 + if (.not.(nm==1))goto 23220 nm=0 23220 continue mm=nm - if(.not.(mm==0))goto 23222 + if (.not.(mm==0))goto 23222 return 23222 continue nm=0 nd=nd+m(mm) - if(.not.(mod(ny,4) == 0 .and. mm > 2))goto 23224 + if (.not.(mod(ny,4) == 0 .and. mm > 2))goto 23224 nd=nd+1 23224 continue return @@ -764,7 +764,7 @@ subroutine staper(nt, fw, nev, v, ndim, a, w) r2 = sqrt(2.) - if(nt < 2) return + if (nt < 2) return nxi=mod(nt,2) lh=(nt/2)+nxi lp1=nt+1 @@ -774,7 +774,7 @@ subroutine staper(nt, fw, nev, v, ndim, a, w) do 10 i=1,lh a(i)=com*(i-hn)**2 10 w(i)=0.5*dble(i*(nt-i)) - if(nxi == 0) then + if (nxi == 0) then asav=a(lh)-w(lh) a(lh)=a(lh)+w(lh) rbd=1./(a(lh)+w(lh-1)) @@ -793,12 +793,12 @@ subroutine staper(nt, fw, nev, v, ndim, a, w) call tsturm(nt,lh,a,a(lh+1),w,neven,v,ndim,w(lh+1),0) do 20 i=1,neven k=2*i-1 - if(nxi == 1) v(lh,k)=r2*v(lh,k) + if (nxi == 1) v(lh,k)=r2*v(lh,k) do 20 j=1,lh 20 v(lp1-j,k)=v(j,k) - if(nodd <= 0) goto 34 + if (nodd <= 0) goto 34 ! Do the odd tapers - if(nxi == 0) then + if (nxi == 0) then a(lh)=asav*rbd else a(nt)=asav*rbd @@ -807,7 +807,7 @@ subroutine staper(nt, fw, nev, v, ndim, a, w) call tsturm(nt,lh-nxi,a,a(lh+1),w,nodd,v,ndim,w(lh+1),1) do 30 i=1,nodd k=2*i - if(nxi == 1) v(lh,k)=0. + if (nxi == 1) v(lh,k)=0. do 30 j=1,lh 30 v(lp1-j,k)=-v(j,k) 34 ntot=neven+nodd @@ -826,7 +826,7 @@ subroutine staper(nt, fw, nev, v, ndim, a, w) vmax=abs(v(1,m)) kmax=1 do 40 kk=2,lh - if(abs(v(kk,m)) <= vmax) goto 40 + if (abs(v(kk,m)) <= vmax) goto 40 kmax=kk vmax=abs(v(kk,m)) 40 continue @@ -868,35 +868,35 @@ subroutine tsturm(nt,n,a,b,w,nev,r,ndim,ev,ipar) !------------------------- - if(n <= 0.or.nev <= 0) return + if (n <= 0.or.nev <= 0) return umeps=1.-epsi do 5 i=1,nev 5 ev(i)=-1. u=1. do 1000 ik=1,nev - if(ik > 1) u=ev(ik-1)*umeps + if (ik > 1) u=ev(ik-1)*umeps el=min(ev(ik),u) 10 elam=0.5*(u+el) - if(abs(u-el) <= epsi1) goto 35 + if (abs(u-el) <= epsi1) goto 35 iag=0 q=a(1)-elam - if(q >= 0.) iag=iag+1 + if (q >= 0.) iag=iag+1 do 15 i=2,n - if(q == 0.) x=abs(b(i-1))/epsi - if(q /= 0.) x=w(i-1)/q + if (q == 0.) x=abs(b(i-1))/epsi + if (q /= 0.) x=w(i-1)/q q=a(i)-elam-x - if(q >= 0.) iag=iag+1 - if(iag > nev) goto 20 + if (q >= 0.) iag=iag+1 + if (iag > nev) goto 20 15 continue - if(iag >= ik) go to 20 + if (iag >= ik) goto 20 u=elam - go to 10 - 20 if(iag == ik) go to 30 + goto 10 + 20 if (iag == ik) goto 30 m=ik+1 do 25 i=m,iag 25 ev(i)=elam el=elam - go to 10 + goto 10 30 el=elam call root(u,el,elam,a,b,w,n,ik) 35 ev(ik)=elam @@ -936,30 +936,30 @@ subroutine root(u,el,elam,a,bb,w,n,ik) !---------------------- 5 elam=0.5*(u+el) - 10 if(abs(u-el) <= 1.5*epsi1) return + 10 if (abs(u-el) <= 1.5*epsi1) return an=a(1)-elam b=0. bn=-1./an iag=0 - if(an >= 0.) iag=iag+1 + if (an >= 0.) iag=iag+1 do 20 i=2,n - if(an == 0.) x=abs(bb(i-1))/epsi - if(an /= 0.) x=w(i-1)/an + if (an == 0.) x=abs(bb(i-1))/epsi + if (an /= 0.) x=w(i-1)/an an=a(i)-elam-x - if(an == 0.) an=epsi + if (an == 0.) an=epsi bm=b b=bn bn=((a(i)-elam)*b-bm*x-1.)/an - if(an >= 0.) iag=iag+1 + if (an >= 0.) iag=iag+1 20 continue - if(iag == ik) goto 25 + if (iag == ik) goto 25 u=elam goto 30 25 el=elam 30 del=1./bn - if(abs(del) <= epsi1) del=sign(epsi1,del) + if (abs(del) <= epsi1) del=sign(epsi1,del) elam=elam-del - if(elam >= u.or.elam <= el) goto 5 + if (elam >= u.or.elam <= el) goto 5 goto 10 end subroutine root diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/gll_library.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/gll_library.f90 index 73c78dbd6..8923f0530 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/gll_library.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/gll_library.f90 @@ -177,7 +177,7 @@ subroutine jacg (xjac,np,alpha,beta) pd = 0.d0 jmin = 0 do j=1,np - if(j == 1) then + if (j == 1) then x = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth) else x1 = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth) @@ -193,7 +193,7 @@ subroutine jacg (xjac,np,alpha,beta) enddo delx = -p/(pd-recsum*p) x = x+delx - if(abs(delx) < eps) goto 31 + if (abs(delx) < eps) goto 31 enddo 31 continue xjac(np-j+1) = x @@ -202,12 +202,12 @@ subroutine jacg (xjac,np,alpha,beta) do i=1,np xmin = 2.d0 do j=i,np - if(xjac(j) < xmin) then + if (xjac(j) < xmin) then xmin = xjac(j) jmin = j endif enddo - if(jmin /= i) then + if (jmin /= i) then swap = xjac(i) xjac(i) = xjac(jmin) xjac(jmin) = swap @@ -278,7 +278,7 @@ end subroutine jacobf !------------------------------------------------------------------------ ! - double precision FUNCTION PNDLEG (Z,N) + double precision function PNDLEG (Z,N) !------------------------------------------------------------------------ ! @@ -318,7 +318,7 @@ end function pndleg !------------------------------------------------------------------------ ! - double precision FUNCTION PNLEG (Z,N) + double precision function PNLEG (Z,N) !------------------------------------------------------------------------ ! diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/lagrange_poly.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/lagrange_poly.f90 index 041f29567..79224d9a0 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/lagrange_poly.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/lagrange_poly.f90 @@ -16,7 +16,7 @@ subroutine lagrange_poly(xi,NGLL,xigll,h,hprime) prod1 = 1.0d0 prod2 = 1.0d0 do i=1,NGLL - if(i /= dgr) then + if (i /= dgr) then prod1 = prod1*(xi-xigll(i)) prod2 = prod2*(xigll(dgr)-xigll(i)) endif @@ -25,10 +25,10 @@ subroutine lagrange_poly(xi,NGLL,xigll,h,hprime) hprime(dgr)=0.0d0 do i=1,NGLL - if(i /= dgr) then + if (i /= dgr) then prod1=1.0d0 do j=1,NGLL - if(j /= dgr .and. j /= i) prod1 = prod1*(xi-xigll(j)) + if (j /= dgr .and. j /= i) prod1 = prod1*(xi-xigll(j)) enddo hprime(dgr) = hprime(dgr)+prod1 endif diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/numerical_recipes.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/numerical_recipes.f90 index e1efdce2b..1e7d4a901 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/numerical_recipes.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/numerical_recipes.f90 @@ -13,7 +13,7 @@ double precision function erf(x) ! this routine uses routine gammp double precision gammp - if(x<0.)then + if (x<0.) then erf=-gammp(0.5d0,x**2) else erf=gammp(0.5d0,x**2) @@ -29,9 +29,9 @@ double precision function gammp(a,x) ! this routine uses routines gcf and gser double precision gammcf,gamser,gln - if(x<0.d0 .or. a <= 0.d0) stop 'bad arguments in gammp' + if (x<0.d0 .or. a <= 0.d0) stop 'bad arguments in gammp' - if(x 1) THEN + 1 if (KHI-KLO > 1) then K=(KHI+KLO)/2 - IF(XA(K) > X)THEN + if (XA(K) > X) then KHI=K ELSE KLO=K @@ -224,7 +224,7 @@ subroutine splint(xa,ya,y2a,n,x,y) goto 1 endif H=XA(KHI)-XA(KLO) - IF (H == 0.d0) stop 'Bad input in spline evaluation' + if (H == 0.d0) stop 'Bad input in spline evaluation' A=(XA(KHI)-X)/H B=(X-XA(KLO))/H diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/test_smooth.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/test_smooth.f90 index 4d8e16afb..2e6dcc689 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/test_smooth.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/test_smooth.f90 @@ -79,22 +79,22 @@ program test_smooth !!$ iglob3 = ibool(1,NGLLZ,ispec) !!$ iglob4 = ibool(NGLLX,NGLLZ,ispec) !!$ -!!$ if(.not. mask_ibool(iglob1)) mask_ibool(iglob1) = .true. -!!$ if(.not. mask_ibool(iglob2)) mask_ibool(iglob2) = .true. -!!$ if(.not. mask_ibool(iglob3)) mask_ibool(iglob3) = .true. -!!$ if(.not. mask_ibool(iglob4)) mask_ibool(iglob4) = .true. +!!$ if (.not. mask_ibool(iglob1)) mask_ibool(iglob1) = .true. +!!$ if (.not. mask_ibool(iglob2)) mask_ibool(iglob2) = .true. +!!$ if (.not. mask_ibool(iglob3)) mask_ibool(iglob3) = .true. +!!$ if (.not. mask_ibool(iglob4)) mask_ibool(iglob4) = .true. !!$ enddo !!$ !!$ k = 0 !!$ ielement_corner(:) = 0 !!$ do iglob = 1,NGLOB -!!$ if(mask_ibool(iglob)) then +!!$ if (mask_ibool(iglob)) then !!$ k = k+1 !!$ ielement_corner(k) = iglob !!$ endif !!$ enddo - if(0==1) then + if (0==1) then ! corner points for each element, and centerpoint (in km) open(unit=15,file='elements.dat',status='unknown') @@ -163,7 +163,7 @@ program test_smooth close(19) ! construct local version of the unsmoothed kernel - if(itype==1) then + if (itype==1) then k_rough_local(:,:,:) = 0. do ispec = 1,NSPEC do j = 1,NGLLZ @@ -186,7 +186,7 @@ program test_smooth dmin = sqrt(LENGTH**2+HEIGHT**2) ! max possible distance do iglob = 1,NGLOB d = sqrt((xtar-x(iglob))**2+(ztar-z(iglob))**2) - if(d < dmin) then + if (d < dmin) then igaus = iglob dmin = d endif @@ -198,7 +198,7 @@ program test_smooth k_gaus_global_ex(:) = 0. do iglob = 1,NGLOB dist2 = (xcen - x(iglob))**2 + (zcen - z(iglob))**2 - if(dist2 <= dtrsh2) & + if (dist2 <= dtrsh2) & k_gaus_global_ex(iglob) = (4./(PI*gamma**2)) * exp(-4.*dist2 / (gamma**2)) enddo @@ -222,7 +222,7 @@ program test_smooth ! (part of the Gaussian may be outside the grid) xcen = x(iglob) zcen = z(iglob) - if(itype==1) then + if (itype==1) then k_gaus_local(:,:,:) = 0. do ispec = 1,NSPEC @@ -230,7 +230,7 @@ program test_smooth do i = 1,NGLLX itemp = ibool(i,j,ispec) dist2 = (xcen - x(itemp))**2 + (zcen - z(itemp))**2 - if(dist2 <= dtrsh2) then + if (dist2 <= dtrsh2) then k_gaus_local(i,j,ispec) = (4./(PI*gamma**2)) * exp(-4.*dist2 / (gamma**2)) !k_gaus_global(itemp) = k_gaus_local(i,j,ispec) endif @@ -242,7 +242,7 @@ program test_smooth k_gaus_global(:) = 0. do i = 1,NGLOB dist2 = (xcen - x(i))**2 + (zcen - z(i))**2 - if(dist2 <= dtrsh2) & + if (dist2 <= dtrsh2) & k_gaus_global(i) = (4./(PI*gamma**2)) * exp(-4.*dist2 / (gamma**2)) enddo endif @@ -252,12 +252,12 @@ program test_smooth ! and accounts for Gaussians that are partially outside the grid. ! (2) Integrate the product of the Gaussian and the rough function. - if(itype==1) then ! local integration with local arrays + if (itype==1) then ! local integration with local arrays k_gaus_int_global(iglob) = sum( k_gaus_local(:,:,:) * da_local(:,:,:) ) k_smooth_global(iglob) = sum( k_rough_local(:,:,:) * k_gaus_local(:,:,:) * da_local(:,:,:) ) / k_gaus_int_global(iglob) - else if(itype==2) then ! local integration with global array + else if (itype==2) then ! local integration with global array k_temp(:,:,:) = 0. do ispec = 1,NSPEC @@ -281,7 +281,7 @@ program test_smooth enddo k_smooth_global(iglob) = sum( k_temp(:,:,:) ) / k_gaus_int_global(iglob) - else if(itype==3) then ! global integration with global arrays + else if (itype==3) then ! global integration with global arrays k_gaus_int_global(iglob) = sum( k_gaus_global(:) * da_global(:) ) k_smooth_global(iglob) = sum( k_rough_global(:) * k_gaus_global(:) * da_global(:) ) / k_gaus_int_global(iglob) diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d.f90 index bf3e373ca..96b9d56f4 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d.f90 @@ -316,7 +316,7 @@ program wave2d open(19,file='INPUT/events_xyt_pert.dat',status='unknown') do ievent = 1,nevent read(19,*) temp1,temp2,temp3 - !if(ievent==5) then + !if (ievent==5) then ! temp1 = -1.599978278510d3 ! temp2 = -6.502537573573d2 ! temp3 = 7.975610515441d-2 @@ -1919,7 +1919,7 @@ program wave2d ! factors for balancing the model norm term ! NOTE: we ignore parts of the model norm that do not participate in the inversion - if ( INV_STRUCT_BETA == 1 .and. INV_SOURCE_T == 0 .and. INV_SOURCE_X == 0 ) then ! structure + if ( INV_STRUCT_BETA == 1 .and. INV_SOURCE_T == 0 .and. INV_SOURCE_X == 0 ) then ! structure fac_str = 1.00 else if ( INV_STRUCT_BETA == 0 .and. INV_SOURCE_T == 1 .and. INV_SOURCE_X == 0 ) then ! origin time fac_ts = 1.00 @@ -3395,7 +3395,7 @@ program wave2d endif !----------------------------------------------------- - ! COMPUTE THE GRADIENT OF THE MISFIT FUNCTION, if the present model is not + ! COMPUTE THE GRADIENT OF THE MISFIT function, if the present model is not ! a test model or if the CG polynomial is a cubic function if ( itest==0 .or. POLY_ORDER==3 ) then diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d_cmap.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d_cmap.f90 index 07eb3d608..1c3db490e 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d_cmap.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d_cmap.f90 @@ -122,7 +122,7 @@ program wave2d_cmap !!$ ! regular mesh or SPECFEM mesh !!$ i_regular = 0 !!$ -!!$ if(i_regular==1) then +!!$ if (i_regular==1) then !!$ !!$ ! enter new uniform mesh !!$ dx = 40.0d+03 @@ -144,7 +144,7 @@ program wave2d_cmap !!$ allocate(c_glob9(ntemp),c_glob_syn9(ntemp),c_glob_dat9(ntemp)) !!$ allocate(da9(ntemp)) !!$ -!!$ if(i_regular==1) then +!!$ if (i_regular==1) then !!$ !!$ k = 0 !!$ do xtemp = -fac,LENGTH+fac,dx @@ -233,7 +233,7 @@ program wave2d_cmap dmin = sqrt(LENGTH**2+HEIGHT**2) ! max possible distance do iglob = 1,NGLOB d = sqrt((xtar-x(iglob))**2+(ztar-z(iglob))**2) - if(d < dmin) then + if (d < dmin) then igaus = iglob dmin = d endif @@ -243,7 +243,7 @@ program wave2d_cmap k_gaus_global_ex(:) = 0. do iglob = 1,NGLOB dist2 = (xcen - x(iglob))**2 + (zcen - z(iglob))**2 - if(dist2 <= dtrsh2) & + if (dist2 <= dtrsh2) & k_gaus_global_ex(iglob) = (1./(2*PI*SIGMA**2)) * exp(-dist2 / (2.*SIGMA**2)) enddo @@ -257,7 +257,7 @@ program wave2d_cmap k_gaus_global(:) = 0. do i = 1,NGLOB dist2 = (xcen - x(i))**2 + (zcen - z(i))**2 - if(dist2 <= dtrsh2) & + if (dist2 <= dtrsh2) & k_gaus_global(i) = (1./(2.*PI*SIGMA**2)) * exp(-dist2 / (2.*SIGMA**2)) enddo diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d_define_der_matrices.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d_define_der_matrices.f90 index 6612f78d9..6b5cb6d9b 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d_define_der_matrices.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d_define_der_matrices.f90 @@ -35,8 +35,8 @@ subroutine define_derivative_matrices(xigll,zigll,wxgll,wzgll,hprime_xx,hprime_z call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA) ! if number of points is odd, the middle abscissa is exactly zero - if(mod(NGLLX,2) /= 0) xigll((NGLLX-1)/2+1) = 0.d0 - if(mod(NGLLZ,2) /= 0) zigll((NGLLZ-1)/2+1) = 0.d0 + if (mod(NGLLX,2) /= 0) xigll((NGLLX-1)/2+1) = 0.d0 + if (mod(NGLLZ,2) /= 0) zigll((NGLLZ-1)/2+1) = 0.d0 ! calculate derivatives of the Lagrange polynomials ! and precalculate some products in double precision diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d_solver.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d_solver.f90 index 4cf71bab3..6a019f311 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d_solver.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d_solver.f90 @@ -33,7 +33,7 @@ subroutine mesher !!$ do ix = 1,NEX !!$ ispec = ispec+1 !!$ -!!$ if(ix==1) then +!!$ if (ix==1) then !!$ !!$ ! evenly spaced anchors between 0 and 1 !!$ !z1temp = HEIGHT*dble(iz-1)/dble(NEZ) @@ -41,13 +41,13 @@ subroutine mesher !!$ !!$ z1temp = z2temp !!$ z2temp = z2temp + HEIGHT/dble(NEZ) ! standard element height -!!$ if(iz==NEZ) z2temp = HEIGHT +!!$ if (iz==NEZ) z2temp = HEIGHT !!$ !!$ ! determine whether the element is cut by a discontinuity !!$ iel = 0 !!$ do k = 1,nlayer-1 !!$ dtemp = HEIGHT - z_breaks(k) -!!$ if(dtemp > z1temp .and. dtemp < z2temp) then +!!$ if (dtemp > z1temp .and. dtemp < z2temp) then !!$ print *, k, iz !!$ iel = 1 !!$ ik = k @@ -56,7 +56,7 @@ subroutine mesher !!$ !iel = 0 !!$ !!$ ! perturb the boundary of the top of the element (z2) -!!$ if(iel == 1) then +!!$ if (iel == 1) then !!$ !!$ zdiff = HEIGHT*LENGTH ! initial difference !!$ do while (zdiff > dtrsh) @@ -66,14 +66,14 @@ subroutine mesher !!$ ! present GLL height (upper layer) !!$ ztemp2 = 0.5*(1.0-zigll(j))*z1temp + 0.5*(1.0+zigll(j))*z2temp !!$ -!!$ if(j > 1) then +!!$ if (j > 1) then !!$ ! previous GLL z height (lower layer) !!$ ztemp1 = 0.5*(1.0-zigll(j-1))*z1temp + 0.5*(1.0+zigll(j-1))*z2temp !!$ !!$ dtemp = HEIGHT - z_breaks(ik) ! height of boundary !!$ !!$ ! discontinuity is inbetween GLL layers -!!$ if(dtemp > ztemp1 .and. dtemp < ztemp2) then +!!$ if (dtemp > ztemp1 .and. dtemp < ztemp2) then !!$ dz1 = abs(dtemp - ztemp1) !!$ dz2 = abs(ztemp2 - dtemp) !!$ zdiff = abs(dz2 - dz1) @@ -208,13 +208,13 @@ subroutine mesher ! estimate the time step dh = HEIGHT/dble((NGLLZ-1)*NEZ) - if(dh > LENGTH/dble((NGLLX-1)*NEX)) dh = LENGTH/dble((NGLLX-1)*NEX) + if (dh > LENGTH/dble((NGLLX-1)*NEX)) dh = LENGTH/dble((NGLLX-1)*NEX) !!$ !c = sqrt((INCOMPRESSIBILITY+FOUR_THIRDS*RIGIDITY)/DENSITY) !!$ !time_step = 0.2*dh/c !!$ print * !!$ print *,' space step (km) :', sngl(dh/1000.0) -!!$ if(ISURFACE==0) then +!!$ if (ISURFACE==0) then !!$ print *,'time step est from courant = 0.2, Pmax : ',sngl(0.2*dh/alpha_max),' seconds' !!$ print *,'time step est from courant = 0.2, Pmin : ',sngl(0.2*dh/alpha_min),' seconds' !!$ print *,'time step est from courant = 0.2, Smax : ',sngl(0.2*dh/beta_max),' seconds' @@ -262,16 +262,16 @@ subroutine mesher_additional iglob3 = ibool(1,NGLLZ,ispec) iglob4 = ibool(NGLLX,NGLLZ,ispec) - if(.not. mask_ibool(iglob1)) mask_ibool(iglob1) = .true. - if(.not. mask_ibool(iglob2)) mask_ibool(iglob2) = .true. - if(.not. mask_ibool(iglob3)) mask_ibool(iglob3) = .true. - if(.not. mask_ibool(iglob4)) mask_ibool(iglob4) = .true. + if (.not. mask_ibool(iglob1)) mask_ibool(iglob1) = .true. + if (.not. mask_ibool(iglob2)) mask_ibool(iglob2) = .true. + if (.not. mask_ibool(iglob3)) mask_ibool(iglob3) = .true. + if (.not. mask_ibool(iglob4)) mask_ibool(iglob4) = .true. enddo k = 0 ielement_corner(:) = 0 do iglob = 1,NGLOB - if(mask_ibool(iglob)) then + if (mask_ibool(iglob)) then k = k+1 ielement_corner(k) = iglob endif @@ -302,13 +302,13 @@ subroutine set_model_property(iref) !!$ do iglob = 1,NGLOB !!$ rho_global(iglob) = DENSITY !!$ kappa_global(iglob) = INCOMPRESSIBILITY -!!$ if(ISURFACE==0) then +!!$ if (ISURFACE==0) then !!$ mu_global(iglob) = RIGIDITY !!$ else !!$ ! KEY: this means that the S velocity will be the surface wave phase velocity (m/s) !!$ mu_global(iglob) = DENSITY*(c_glob(iglob))**2 -!!$ !if(ihomo==1) mu_global(iglob) = DENSITY*beta0**2 -!!$ !if(ihomo==0) mu_global(iglob) = DENSITY*(c_glob(iglob))**2 +!!$ !if (ihomo==1) mu_global(iglob) = DENSITY*beta0**2 +!!$ !if (ihomo==0) mu_global(iglob) = DENSITY*(c_glob(iglob))**2 !!$ endif !!$ enddo @@ -319,10 +319,10 @@ subroutine set_model_property(iref) print * print *, 'setting model properties at a local scale' - if(iref==1) print *, ' --> reference model (synthetics), IMODEL_SYN = ', IMODEL_SYN - if(iref==0) print *, ' --> target model (data), IMODEL_DAT = ', IMODEL_DAT - if(IMODEL_SYN > 3) stop 'IMODEL_SYN must be 0,1,2,3' - if(IMODEL_DAT > 3) stop 'IMODEL_DAT must be 0,1,2,3' + if (iref==1) print *, ' --> reference model (synthetics), IMODEL_SYN = ', IMODEL_SYN + if (iref==0) print *, ' --> target model (data), IMODEL_DAT = ', IMODEL_DAT + if (IMODEL_SYN > 3) stop 'IMODEL_SYN must be 0,1,2,3' + if (IMODEL_DAT > 3) stop 'IMODEL_DAT must be 0,1,2,3' !----------------- ! fill local arrays of the reference structure model @@ -335,7 +335,7 @@ subroutine set_model_property(iref) ! structure for reference model (synthetics) if (iref==1) then - if(IMODEL_SYN == 0) then ! homogeneous model + if (IMODEL_SYN == 0) then ! homogeneous model !kappa_syn(i,j,ispec) = INCOMPRESSIBILITY !mu_syn(i,j,ispec) = RIGIDITY @@ -345,9 +345,9 @@ subroutine set_model_property(iref) mu_syn(i,j,ispec) = DENSITY*beta0*beta0 rho_syn(i,j,ispec) = DENSITY - else if(IMODEL_SYN == 1) then ! 1D model (body waves) + else if (IMODEL_SYN == 1) then ! 1D model (body waves) - if(ISURFACE==0) then + if (ISURFACE==0) then call make_1D_model(i,j,ispec,ktemp,mtemp,rtemp) ! 1D model kappa_syn(i,j,ispec) = ktemp mu_syn(i,j,ispec) = mtemp @@ -356,11 +356,11 @@ subroutine set_model_property(iref) stop 'check model in set_model_property.f90' endif - else if(IMODEL_SYN == 2) then ! checkerboard model - if(ISURFACE==0) then + else if (IMODEL_SYN == 2) then ! checkerboard model + if (ISURFACE==0) then stop 'check model in set_model_property.f90' - else if(ISURFACE==1) then + else if (ISURFACE==1) then ! checkerboard S-wave velocity (= membrane wave phase velocity) ! GLOBALLY defined (not at the elemental level) btemp2 = beta0 * (1.0 + afac/100.0*(sin(x(iglob)*w_scale) * sin(z(iglob)*w_scale)) ) @@ -370,8 +370,8 @@ subroutine set_model_property(iref) rho_syn(i,j,ispec) = DENSITY endif - else if(IMODEL_SYN == 3) then ! heterogeneous model - if(ISURFACE==0) then + else if (IMODEL_SYN == 3) then ! heterogeneous model + if (ISURFACE==0) then stop 'check model in set_model_property.f90' else @@ -394,7 +394,7 @@ subroutine set_model_property(iref) atemp = sqrt( (ktemp + FOUR_THIRDS*mtemp) / rtemp ) btemp = sqrt( mtemp / rtemp ) - if(IMODEL_DAT == 0) then ! uniform perturbation + if (IMODEL_DAT == 0) then ! uniform perturbation ! perturbations ( i.e., dm = m-m0 , NOT dm/m0 ) dalpha2 = atemp*dalpha @@ -413,9 +413,9 @@ subroutine set_model_property(iref) kappa_dat(i,j,ispec) = ktemp + dkappa2 mu_dat(i,j,ispec) = mtemp + dmu2 - else if(IMODEL_DAT == 1) then ! 1D model (NOT a 1D perturbation) + else if (IMODEL_DAT == 1) then ! 1D model (NOT a 1D perturbation) - if(ISURFACE==0) then + if (ISURFACE==0) then call make_1D_model(i,j,ispec,ktemp,mtemp,rtemp) ! 1D model else @@ -425,9 +425,9 @@ subroutine set_model_property(iref) mu_dat(i,j,ispec) = mtemp rho_dat(i,j,ispec) = rtemp - else if(IMODEL_DAT == 2) then ! checkerboard perturbation + else if (IMODEL_DAT == 2) then ! checkerboard perturbation - if(ISURFACE==0) then + if (ISURFACE==0) then stop 'check model in set_model_property.f90' else ! GJI-2007 paper @@ -443,9 +443,9 @@ subroutine set_model_property(iref) !rho_dat(i,j,ispec) = DENSITY endif - else if(IMODEL_DAT == 3) then ! heterogeneous perturbation + else if (IMODEL_DAT == 3) then ! heterogeneous perturbation - if(ISURFACE==0) then + if (ISURFACE==0) then stop 'check model in set_model_property.f90' else @@ -462,7 +462,7 @@ subroutine set_model_property(iref) enddo enddo - if(iref == 1) then + if (iref == 1) then alpha_syn = 0.0 ; beta_syn = 0.0 ; bulk_syn = 0.0 alpha_syn = sqrt( (kappa_syn + FOUR_THIRDS*mu_syn) / rho_syn ) beta_syn = sqrt( mu_syn / rho_syn ) @@ -493,39 +493,39 @@ subroutine make_1D_model(i,j,ispec,kappa1,mu1,rho1) iglob = ibool(i,j,ispec) dtemp = HEIGHT - z(iglob) ! depth of GLL point - if(dtemp < z_breaks(1)) then ! shallow surface + if (dtemp < z_breaks(1)) then ! shallow surface rtemp = r_layers(1) ; atemp = a_layers(1) ; btemp = b_layers(1) - else if(dtemp == z_breaks(1)) then ! 'basin' reflector - if(HEIGHT-z1(ispec) == dtemp) then + else if (dtemp == z_breaks(1)) then ! 'basin' reflector + if (HEIGHT-z1(ispec) == dtemp) then rtemp = r_layers(1) ; atemp = a_layers(1) ; btemp = b_layers(1) - else if(HEIGHT-z2(ispec) == dtemp) then + else if (HEIGHT-z2(ispec) == dtemp) then rtemp = r_layers(2) ; atemp = a_layers(2) ; btemp = b_layers(2) else print *, dtemp, z_breaks(1), z1(ispec), z2(ispec) stop 'error in make_1D_model.f90' endif - else if(dtemp > z_breaks(1) .and. dtemp < z_breaks(2)) then ! upper crust + else if (dtemp > z_breaks(1) .and. dtemp < z_breaks(2)) then ! upper crust rtemp = r_layers(2) ; atemp = a_layers(2) ; btemp = b_layers(2) - else if(dtemp == z_breaks(2)) then ! mid-crust reflector - if(HEIGHT-z1(ispec) == dtemp) then + else if (dtemp == z_breaks(2)) then ! mid-crust reflector + if (HEIGHT-z1(ispec) == dtemp) then rtemp = r_layers(2) ; atemp = a_layers(2) ; btemp = b_layers(2) - else if(HEIGHT-z2(ispec) == dtemp) then + else if (HEIGHT-z2(ispec) == dtemp) then rtemp = r_layers(3) ; atemp = a_layers(3) ; btemp = b_layers(3) else print *, dtemp, z_breaks(2), z1(ispec), z2(ispec) stop 'error in make_1D_model.f90' endif - else if(dtemp > z_breaks(2) .and. dtemp < z_breaks(3)) then ! lower crust + else if (dtemp > z_breaks(2) .and. dtemp < z_breaks(3)) then ! lower crust rtemp = r_layers(3) ; atemp = a_layers(3) ; btemp = b_layers(3) - else if(dtemp == z_breaks(3)) then ! Moho - if(HEIGHT-z1(ispec) == dtemp) then + else if (dtemp == z_breaks(3)) then ! Moho + if (HEIGHT-z1(ispec) == dtemp) then rtemp = r_layers(3) ; atemp = a_layers(3) ; btemp = b_layers(3) - else if(HEIGHT-z2(ispec) == dtemp) then + else if (HEIGHT-z2(ispec) == dtemp) then rtemp = r_layers(4) ; atemp = a_layers(4) ; btemp = b_layers(4) else print *, dtemp, z_breaks(3), z1(ispec), z2(ispec) @@ -603,8 +603,8 @@ subroutine solver(solver_type, idata, & !-------------------------------------- - if(NCOMP==3) fm = '(9e12.3)' - if(NCOMP==1) fm = '(3e12.3)' + if (NCOMP==3) fm = '(9e12.3)' + if (NCOMP==1) fm = '(3e12.3)' ! test of input arguments if (solver_type /= 1 .and. solver_type /= 2 .and. solver_type /= 3) then @@ -649,7 +649,7 @@ subroutine solver(solver_type, idata, & ! gridpoints per wavelength estimation -- based on TARGET model (data) print * print *, 'space step (km):', sngl(dh/1000.0) - if(ISURFACE==1) then + if (ISURFACE==1) then print *, 'wavelength-min (km):', sngl(2*hdur*beta_min/1000.0) print *, 'wavelength-max (km):', sngl(2*hdur*beta_max/1000.0) print *, 'number of gridpoints per wavelength for S:' @@ -740,7 +740,7 @@ subroutine solver(solver_type, idata, & rho_c_beta_kernel = 0.0 ! allocate interaction fields for 9 (3 x 3) kernels - if(WRITE_KERNEL_SNAPSHOTS) then + if (WRITE_KERNEL_SNAPSHOTS) then allocate(kappa_mu_rho_kernel_int(NGLLX,NGLLZ,NSPEC)) allocate(mu_kappa_rho_kernel_int(NGLLX,NGLLZ,NSPEC)) allocate(rho_kappa_mu_kernel_int(NGLLX,NGLLZ,NSPEC)) @@ -778,9 +778,9 @@ subroutine solver(solver_type, idata, & enddo ! displacement gradient at the source element GLL points at each time step - if(solver_type == 3) displ_grad = 0.0 + if (solver_type == 3) displ_grad = 0.0 - if(NCOMP==1) then ! SH, or surface waves only + if (NCOMP==1) then ! SH, or surface waves only ! ! INTEGRATION OVER SPECTRAL ELEMENTS @@ -830,7 +830,7 @@ subroutine solver(solver_type, idata, & ! save spatial gradient for (point) source perturbations ! NOTE: point source only (nsrc=1) - if(solver_type == 3 .and. ispec == ispec_src(1)) then + if (solver_type == 3 .and. ispec == ispec_src(1)) then displ_grad(i,j,1) = dsydxl displ_grad(i,j,2) = dsydzl !displ_grad(i,j,3) = dsydxl @@ -936,13 +936,13 @@ subroutine solver(solver_type, idata, & ! sections need to be adjusted as well do ibb = 1,NABSORB ! index of grid boundary - if(ibb == 1) then + if (ibb == 1) then i = 1 - else if(ibb == 2) then + else if (ibb == 2) then i = NGLLX - else if(ibb == 3) then + else if (ibb == 3) then i = 1 - else if(ibb == 4) then + else if (ibb == 4) then i = NGLLZ endif @@ -1054,7 +1054,7 @@ subroutine solver(solver_type, idata, & dszdzl = tempz1l*dxidzl+tempz2l*dgammadzl ! save spatial gradient for (point) source perturbations - if(solver_type == 3 .and. ispec == ispec_src(1)) then + if (solver_type == 3 .and. ispec == ispec_src(1)) then displ_grad(i,j,1) = dsxdxl displ_grad(i,j,2) = dsxdzl displ_grad(i,j,3) = dsydxl @@ -1381,7 +1381,7 @@ subroutine solver(solver_type, idata, & do i = 1,NGLOB accel(:,i) = accel(:,i)/mass_global(i) - if(solver_type == 3) & + if (solver_type == 3) & b_accel(:,i) = b_accel(:,i)/mass_global(i) enddo @@ -1410,7 +1410,7 @@ subroutine solver(solver_type, idata, & ! equivalent to using closest gridpoint -- OLD METHOD !hlagrange = 0.0 - !if(iglob == rglob(irec)) hlagrange = 1.0 + !if (iglob == rglob(irec)) hlagrange = 1.0 ramp(itime,:,irec) = ramp(itime,:,irec) + displ(:,iglob)*hlagrange enddo @@ -1467,7 +1467,7 @@ subroutine solver(solver_type, idata, & ! DEBUG ARRAY SIZES ! additional time series for checking - if(0==1) then + if (0==1) then three_source_model(NSTEP-itime+1,icomp,nsrc,4) = temp1 three_source_model(NSTEP-itime+1,icomp,nsrc,5) = temp2 three_source_model(NSTEP-itime+1,icomp,nsrc,6) = temp3 @@ -1479,7 +1479,7 @@ subroutine solver(solver_type, idata, & enddo ! icomp enddo ! isrc - if(solver_type==3) then + if (solver_type==3) then ! CALCULATE ALL NINE KERNELS ! note the TIME INTEGRATION @@ -1515,7 +1515,7 @@ subroutine solver(solver_type, idata, & + mu_kappa_rho_kernel(i,j,ispec) ! interaction fields -- each is integrated to form a kernel - if(WRITE_KERNEL_SNAPSHOTS) then + if (WRITE_KERNEL_SNAPSHOTS) then ! kappa-mu-rho kappa_mu_rho_kernel_int(i,j,ispec) = -kappa(i,j,ispec) * kappa_k(i,j,ispec) mu_kappa_rho_kernel_int(i,j,ispec) = -2.0*mu(i,j,ispec) * mu_k(i,j,ispec) @@ -1567,8 +1567,8 @@ subroutine solver(solver_type, idata, & if (itime /= 1) tlab = itime !if (mod(itime, NSAVE) == 0) then if (solver_type == 1) then - if(idata==0) write(filename1,'(a,i5.5)') trim(out_dir)//'forward_syn_',tlab - if(idata==1) write(filename1,'(a,i5.5)') trim(out_dir)//'forward_dat_',tlab + if (idata==0) write(filename1,'(a,i5.5)') trim(out_dir)//'forward_syn_',tlab + if (idata==1) write(filename1,'(a,i5.5)') trim(out_dir)//'forward_dat_',tlab else if (solver_type == 2) then write(filename1,'(a,i5.5)') trim(out_dir)//'adjoint_',tlab else @@ -1580,7 +1580,7 @@ subroutine solver(solver_type, idata, & !write(filename6,'(a,i5.5)') trim(out_dir)//'interaction_',tlab ! interaction endif - if(WRITE_WAVFIELD_SNAPSHOTS) then ! wavefield snapshots (globally defined) + if (WRITE_WAVFIELD_SNAPSHOTS) then ! wavefield snapshots (globally defined) open(unit=11, file=trim(filename1), status='unknown', iostat=ios) if (ios /= 0) stop 'Error writing snapshot to disk' do iglob = 1, NGLOB @@ -1589,8 +1589,8 @@ subroutine solver(solver_type, idata, & close(11) endif - if(WRITE_KERNEL_SNAPSHOTS) then ! kernel snapshots (LOCALLY defined) - if(solver_type == 3) then + if (WRITE_KERNEL_SNAPSHOTS) then ! kernel snapshots (LOCALLY defined) + if (solver_type == 3) then open(unit=11, file=trim(filename2), status='unknown', iostat=ios) if (ios /= 0) stop 'Error writing snapshot to disk' do iglob = 1, NGLOB @@ -1647,7 +1647,7 @@ subroutine solver(solver_type, idata, & ! stop if wavefield contains NaN (13-Aug-2006) !do i=1,ncomp ! do j=1,nglob - ! if( isnan(displ(i,j)) ) stop 'exiting: encountered NaN in solver.f90' + ! if ( isnan(displ(i,j)) ) stop 'exiting: encountered NaN in solver.f90' ! enddo !enddo @@ -1660,7 +1660,7 @@ subroutine solver(solver_type, idata, & ! write out all nine kernels ! (Using local2global is a bit safer.) - if(WRITE_KERNELS) then + if (WRITE_KERNELS) then filename5 = trim(out_dir)//'kernel_basis' open(unit = 13, file = trim(filename5), status = 'unknown',iostat=ios) if (ios /= 0) stop 'Error writing all nine kernels to disk' @@ -1710,7 +1710,7 @@ subroutine solver(solver_type, idata, & deallocate(c_beta_rho_kernel, beta_c_rho_kernel, rho_c_beta_kernel) ! deallocate interaction fields - if(WRITE_KERNEL_SNAPSHOTS) then + if (WRITE_KERNEL_SNAPSHOTS) then deallocate(kappa_mu_rho_kernel_int, mu_kappa_rho_kernel_int, rho_kappa_mu_kernel_int) deallocate(alpha_beta_rho_kernel_int, beta_alpha_rho_kernel_int, rho_alpha_beta_kernel_int) deallocate(c_beta_rho_kernel_int, beta_c_rho_kernel_int, rho_c_beta_kernel_int) diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d_sub.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d_sub.f90 index de8347880..9a1330cfe 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d_sub.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d_sub.f90 @@ -43,8 +43,8 @@ subroutine write_parameters(filename) write(12,*) 'ISRC_TIME',ISRC_TIME write(12,*) 'hdur',hdur write(12,*) 'tshift',tshift - if(SRC_TAPER) write(12,*) 'SRC_TAPER 1' - if(.not. SRC_TAPER) write(12,*) 'SRC_TAPER 0' + if (SRC_TAPER) write(12,*) 'SRC_TAPER 1' + if (.not. SRC_TAPER) write(12,*) 'SRC_TAPER 0' write(12,*) 'FNORM',FNORM write(12,*) 'FOR_X',FOR_X write(12,*) 'FOR_Y',FOR_Y @@ -72,8 +72,8 @@ subroutine write_parameters(filename) write(12,*) 'PRHO',PRHO write(12,*) 'IMODEL_SYN',IMODEL_SYN write(12,*) 'IMODEL_DAT',IMODEL_DAT - if(M0ISMPRIOR) write(12,*) 'M0ISMPRIOR 1' - if(.not. M0ISMPRIOR) write(12,*) 'M0ISMPRIOR 0' + if (M0ISMPRIOR) write(12,*) 'M0ISMPRIOR 1' + if (.not. M0ISMPRIOR) write(12,*) 'M0ISMPRIOR 0' write(12,*) 'ISMOOTH_EVENT_KERNEL',ISMOOTH_EVENT_KERNEL write(12,*) 'ISMOOTH_MISFIT_KERNEL',ISMOOTH_MISFIT_KERNEL write(12,*) 'ISMOOTH_INITIAL_MODEL',ISMOOTH_INITIAL_MODEL @@ -82,44 +82,44 @@ subroutine write_parameters(filename) write(12,*) 'SIGMA_SMOOTH_MODEL',SIGMA_SMOOTH_MODEL write(12,*) 'GAMMA_SMOOTH_KERNEL',GAMMA_SMOOTH_KERNEL write(12,*) 'GAMMA_SMOOTH_MODEL',GAMMA_SMOOTH_MODEL - if(HIGH_RES_SMOOTHING) write(12,*) 'HIGH_RES_SMOOTHING 1' - if(.not. HIGH_RES_SMOOTHING) write(12,*) 'HIGH_RES_SMOOTHING 0' - if(EXAMPLE_Gaussian) write(12,*) 'EXAMPLE_Gaussian 1' - if(.not. EXAMPLE_Gaussian) write(12,*) 'EXAMPLE_Gaussian 0' + if (HIGH_RES_SMOOTHING) write(12,*) 'HIGH_RES_SMOOTHING 1' + if (.not. HIGH_RES_SMOOTHING) write(12,*) 'HIGH_RES_SMOOTHING 0' + if (EXAMPLE_Gaussian) write(12,*) 'EXAMPLE_Gaussian 1' + if (.not. EXAMPLE_Gaussian) write(12,*) 'EXAMPLE_Gaussian 0' write(12,*) 'IKER',IKER write(12,*) 'IAMP_VEL',IAMP_VEL write(12,*) 'ISURFACE',ISURFACE write(12,*) 'NCOMP',NCOMP write(12,*) 'NABSORB',NABSORB - if(WRITE_STF_F) write(12,*) 'WRITE_STF_F 1' - if(.not. WRITE_STF_F) write(12,*) 'WRITE_STF_F 0' - if(WRITE_SEISMO_F) write(12,*) 'WRITE_SEISMO_F 1' - if(.not. WRITE_SEISMO_F) write(12,*) 'WRITE_SEISMO_F 0' - if(WRITE_SEISMO_RECONSTRUCT) write(12,*) 'WRITE_SEISMO_RECONSTRUCT 1' - if(.not. WRITE_SEISMO_RECONSTRUCT) write(12,*) 'WRITE_SEISMO_RECONSTRUCT 0' - if(WRITE_STF_A) write(12,*) 'WRITE_STF_A 1' - if(.not. WRITE_STF_A) write(12,*) 'WRITE_STF_A 0' - if(WRITE_SEISMO_A) write(12,*) 'WRITE_SEISMO_A 1' - if(.not. WRITE_SEISMO_A) write(12,*) 'WRITE_SEISMO_A 0' + if (WRITE_STF_F) write(12,*) 'WRITE_STF_F 1' + if (.not. WRITE_STF_F) write(12,*) 'WRITE_STF_F 0' + if (WRITE_SEISMO_F) write(12,*) 'WRITE_SEISMO_F 1' + if (.not. WRITE_SEISMO_F) write(12,*) 'WRITE_SEISMO_F 0' + if (WRITE_SEISMO_RECONSTRUCT) write(12,*) 'WRITE_SEISMO_RECONSTRUCT 1' + if (.not. WRITE_SEISMO_RECONSTRUCT) write(12,*) 'WRITE_SEISMO_RECONSTRUCT 0' + if (WRITE_STF_A) write(12,*) 'WRITE_STF_A 1' + if (.not. WRITE_STF_A) write(12,*) 'WRITE_STF_A 0' + if (WRITE_SEISMO_A) write(12,*) 'WRITE_SEISMO_A 1' + if (.not. WRITE_SEISMO_A) write(12,*) 'WRITE_SEISMO_A 0' if (WRITE_KERNELS) write(12,*) 'WRITE_KERNELS 1' if (.not. WRITE_KERNELS) write(12,*) 'WRITE_KERNELS 0' if (WRITE_KERNEL_SNAPSHOTS) write(12,*) 'WRITE_KERNEL_SNAPSHOTS 1' if (.not. WRITE_KERNEL_SNAPSHOTS) write(12,*) 'WRITE_KERNEL_SNAPSHOTS 0' - if(WRITE_WAVFIELD_SNAPSHOTS) write(12,*) 'WRITE_WAVFIELD_SNAPSHOTS 1' - if(.not. WRITE_WAVFIELD_SNAPSHOTS) write(12,*) 'WRITE_WAVFIELD_SNAPSHOTS 0' - if(COMPUTE_KERNELS) write(12,*) 'COMPUTE_KERNELS 1' - if(.not. COMPUTE_KERNELS) write(12,*) 'COMPUTE_KERNELS 0' - if(READ_IN) write(12,*) 'READ_IN 1' - if(.not. READ_IN) write(12,*) 'READ_IN 0' - if(READ_SINGLE) write(12,*) 'READ_SINGLE 1' - if(.not. READ_SINGLE) write(12,*) 'READ_SINGLE 0' + if (WRITE_WAVFIELD_SNAPSHOTS) write(12,*) 'WRITE_WAVFIELD_SNAPSHOTS 1' + if (.not. WRITE_WAVFIELD_SNAPSHOTS) write(12,*) 'WRITE_WAVFIELD_SNAPSHOTS 0' + if (COMPUTE_KERNELS) write(12,*) 'COMPUTE_KERNELS 1' + if (.not. COMPUTE_KERNELS) write(12,*) 'COMPUTE_KERNELS 0' + if (READ_IN) write(12,*) 'READ_IN 1' + if (.not. READ_IN) write(12,*) 'READ_IN 0' + if (READ_SINGLE) write(12,*) 'READ_SINGLE 1' + if (.not. READ_SINGLE) write(12,*) 'READ_SINGLE 0' write(12,*) 'NITERATION',NITERATION write(12,*) 'VAR_RED_MIN',VAR_RED_MIN write(12,*) 'SIGMA_DT',SIGMA_DT write(12,*) 'SIGMA_DLNA',SIGMA_DLNA write(12,*) 'SIGMA_WAVEFORM',SIGMA_WAVEFORM - if(ADD_DATA_ERRORS) write(12,*) 'ADD_DATA_ERRORS 1' - if(.not. ADD_DATA_ERRORS) write(12,*) 'ADD_DATA_ERRORS 0' + if (ADD_DATA_ERRORS) write(12,*) 'ADD_DATA_ERRORS 1' + if (.not. ADD_DATA_ERRORS) write(12,*) 'ADD_DATA_ERRORS 0' write(12,*) 'POLY_ORDER',POLY_ORDER write(12,*) 'PERT_STRUCT_BETA',PERT_STRUCT_BETA write(12,*) 'PERT_SOURCE_T',PERT_SOURCE_T @@ -127,10 +127,10 @@ subroutine write_parameters(filename) write(12,*) 'INV_STRUCT_BETA',INV_STRUCT_BETA write(12,*) 'INV_SOURCE_T',INV_SOURCE_T write(12,*) 'INV_SOURCE_X',INV_SOURCE_X - if(INCLUDE_MODEL_NORM) write(12,*) 'INCLUDE_MODEL_NORM 1' - if(.not. INCLUDE_MODEL_NORM) write(12,*) 'INCLUDE_MODEL_NORM 0' - if(ISOURCE_LOG) write(12,*) 'ISOURCE_LOG 1' - if(.not. ISOURCE_LOG) write(12,*) 'ISOURCE_LOG 0' + if (INCLUDE_MODEL_NORM) write(12,*) 'INCLUDE_MODEL_NORM 1' + if (.not. INCLUDE_MODEL_NORM) write(12,*) 'INCLUDE_MODEL_NORM 0' + if (ISOURCE_LOG) write(12,*) 'ISOURCE_LOG 1' + if (.not. ISOURCE_LOG) write(12,*) 'ISOURCE_LOG 0' write(12,*) 'NVAR_STRUCT',NVAR_STRUCT write(12,*) 'NVAR_SOURCE',NVAR_SOURCE write(12,*) 'NVAR',NVAR @@ -143,8 +143,8 @@ subroutine write_parameters(filename) write(12,*) 'BWAVESPEED',BWAVESPEED write(12,*) 'HWIN1',HWIN1 write(12,*) 'HWIN2',HWIN2 - if(SUPPRESS_UTM_PROJECTION) write(12,*) 'SUPPRESS_UTM_PROJECTION 1' - if(.not. SUPPRESS_UTM_PROJECTION) write(12,*) 'SUPPRESS_UTM_PROJECTION 0' + if (SUPPRESS_UTM_PROJECTION) write(12,*) 'SUPPRESS_UTM_PROJECTION 1' + if (.not. SUPPRESS_UTM_PROJECTION) write(12,*) 'SUPPRESS_UTM_PROJECTION 0' write(12,*) 'ILONGLAT2UTM',ILONGLAT2UTM write(12,*) 'IUTM2LONGLAT',IUTM2LONGLAT write(12,*) 'ILONLAT2MESH',ILONLAT2MESH @@ -320,13 +320,13 @@ subroutine get_source_time_function(origin_time,stf_vec,ti) fgaus = 1.0d-8 ! fraction of amplitude at edge of Gaussian dgaus = sqrt(-log(fgaus)) / alpha - if(ISRC_TIME==1) then ! Ricker + if (ISRC_TIME==1) then ! Ricker amp = -2.0*(alpha**3)/dsqrt(PI) - else if(ISRC_TIME==2) then ! Gaussian + else if (ISRC_TIME==2) then ! Gaussian amp = alpha/dsqrt(PI) - else if(ISRC_TIME==3) then ! truncated sine + else if (ISRC_TIME==3) then ! truncated sine cyc = 3.0 per = 2.*hdur !t1 = -0.50*per @@ -334,11 +334,11 @@ subroutine get_source_time_function(origin_time,stf_vec,ti) t2 = t1 + per*cyc amp = alpha**2.0*dsqrt(2.0/PI)*exp(-0.5) - else if(ISRC_TIME==4) then ! sine + else if (ISRC_TIME==4) then ! sine per = 2.0*hdur amp = alpha**2.0*dsqrt(2.0/PI)*exp(-0.5) -!!$ else if(ISRC_TIME==5) then ! plane wave field +!!$ else if (ISRC_TIME==5) then ! plane wave field !!$ !!$ amp = alpha**2*dsqrt(2./PI)*exp(-0.5) ! amplitude !!$ az = 25.*PI/180.0 ! azimuth of vector (from north) @@ -374,39 +374,39 @@ subroutine get_source_time_function(origin_time,stf_vec,ti) t = ti(itime) - origin_time ! time shift - if(ISRC_TIME==1) then + if (ISRC_TIME==1) then ! d/dt[Gaussian] wavelet - if(t >= -dgaus .and. t <= dgaus) then + if (t >= -dgaus .and. t <= dgaus) then stf = amp*t*exp(-alpha*alpha*t*t) else stf = 0.0 endif - else if(ISRC_TIME==2) then + else if (ISRC_TIME==2) then ! Error function ! source_time_function = 0.5*(1.0+erf(decay_rate*t/hdur)) ! Gaussian (this one causes static offset at stations) - if(t >= -dgaus .and. t <= dgaus) then + if (t >= -dgaus .and. t <= dgaus) then stf = amp*exp(-alpha*alpha*t*t) else stf = 0.0 endif - else if(ISRC_TIME==3) then + else if (ISRC_TIME==3) then ! truncated sine function (duration is cyc*per seconds) - if(t >= t1 .and. t <= t2) then + if (t >= t1 .and. t <= t2) then stf = amp*sin(2.0*PI*(t-t1)/per) else stf = 0.0 endif - else if(ISRC_TIME==4) then + else if (ISRC_TIME==4) then ! sine function stf = amp*sin(2*PI*t/per) !stf = amp/2.*sin(2*PI*t/per) + amp/2.*sin(2*PI*t/(1.1*per)) - !else if(ISRC_TIME==5) then + !else if (ISRC_TIME==5) then ! ! plane wavefield, dependant on source position ! tmp = t - d_vec(i)/c_source ! !stf = amp*sin( 2*PI/per*tmp ) @@ -422,7 +422,7 @@ subroutine get_source_time_function(origin_time,stf_vec,ti) ! taper time series ! DO WE WANT TO SIMPLY DETREND THE TIME SERIES? - if(SRC_TAPER) call taper_series(stf_vec(:),NSTEP) + if (SRC_TAPER) call taper_series(stf_vec(:),NSTEP) end subroutine get_source_time_function @@ -468,7 +468,7 @@ subroutine write_snapshot(disp, filename) if (ios /= 0) stop 'Error writing snapshot to disk' do iglob = 1, NGLOB ! DEBUG ARRAY SIZE - if(NCOMP==3) then + if (NCOMP==3) then write(11,'(5e12.3)') x(iglob)/LENGTH, z(iglob)/LENGTH, & sngl(disp(1,iglob)),sngl(disp(2,iglob)),sngl(disp(3,iglob)) else @@ -604,7 +604,7 @@ end subroutine write_time_series !!$ ! specify input time series !!$ in(:) = seis(:,icomp,irec) !!$ -!!$ if(0==1) then +!!$ if (0==1) then !!$ ! write input data to file !!$ write(filename,'(a,a,i5.5,a,i1.1)') trim(seis_name), '_in_', irec, '_', icomp !!$ open(unit=10, file=filename, status='unknown', iostat=ios) @@ -618,7 +618,7 @@ end subroutine write_time_series !!$ ! KEY: Fourier transform !!$ call dfftw_execute(plan) !!$ -!!$ if(write_spectra) then +!!$ if (write_spectra) then !!$ write(filename2,'(a,a,i5.5,a,i1.1)') trim(seis_name), '_', irec, '_', icomp !!$ open(unit=12, file=filename2, status='unknown', iostat=ios) !!$ if (ios /= 0) stop 'Error opening seismogram spectra to write' @@ -635,14 +635,14 @@ end subroutine write_time_series !!$ !ph_val = atan2(im,re) !!$ !!$ ! if within the frequency band -!!$ if(w >= wmin_win .and. w <= wmax_win) abs_int = abs_int + abs_val +!!$ if (w >= wmin_win .and. w <= wmax_win) abs_int = abs_int + abs_val !!$ -!!$ if(write_spectra) write(12,'(2e16.6)') w, abs_val -!!$ !if(write_spectra.and.w/=0.0) write(12,'(2e16.6)') (2*PI)/w, abs_val +!!$ if (write_spectra) write(12,'(2e16.6)') w, abs_val +!!$ !if (write_spectra.and.w/=0.0) write(12,'(2e16.6)') (2*PI)/w, abs_val !!$ enddo -!!$ if(write_spectra) close(12) +!!$ if (write_spectra) close(12) !!$ -!!$ if(0==1) then +!!$ if (0==1) then !!$ write(*,'(a,3f12.4)') ' T, s (min/0/max) :', (2*PI)/wmax_win , 2*hdur , (2*PI)/wmin_win !!$ write(*,'(a,3f12.4)') ' f, Hz (min/0/max) :', wmin_win/(2*PI) , 1/(2*hdur) , wmax_win/(2*PI) !!$ write(*,'(a,3f12.4)') ' w, rad/s (min/0/max) :', wmin_win , 2*PI/(2*hdur) , wmax_win @@ -752,7 +752,7 @@ end subroutine write_time_series !!$ !--------------------------- !!$ !!$ ! calculate velocity and acceleration from syn (traveltime adjoint source only) -!!$ if(IKER >= 1) then +!!$ if (IKER >= 1) then !!$ do itime = 2, NSTEP-1 !!$ syn_veloc(itime,:,irec) = (syn(itime+1,:,irec) - syn(itime-1,:,irec)) / (2 * DT) !!$ enddo @@ -770,18 +770,18 @@ end subroutine write_time_series !!$ !!$ do i = 1,NCOMP !!$ -!!$ if(IKER==0) then ! waveform +!!$ if (IKER==0) then ! waveform !!$ !!$ adj_syn(:,i,irec) = ( syn(:,i,irec) - data(:,i,irec) ) * time_window(:) !!$ -!!$ else if(IKER==5) then ! traveltime +!!$ else if (IKER==5) then ! traveltime !!$ !!$ ! minus sign is shifted from norm to adj_syn, in comparison with Tromp et al (2005) !!$ ! thus, norm is ensured to be POSITIVE (N > 0) !!$ norm = -DT * sum( time_window(:) * syn(:,i,irec) * syn_accel(:,i,irec) ) !!$ if (abs(norm) > EPS) adj_syn(:,i,irec) = -syn_veloc(:,i,irec) * time_window(:) / norm !!$ -!!$ else if(IKER==6) then ! amplitude +!!$ else if (IKER==6) then ! amplitude !!$ !!$ ! norm is ensured to be POSITIVE (M > 0) !!$ norm = DT * sum( time_window(:) * syn(:,i,irec) * syn(:,i,irec) ) @@ -858,7 +858,7 @@ subroutine smooth_global_function(rough_global, gamma, smooth_global) ! All points outside d^2 (dtrsh2) are set to zero. dtrsh2 = (1.5*gamma)**2 - if(EXAMPLE_Gaussian) then + if (EXAMPLE_Gaussian) then ! EXAMPLE global Gaussian smoothing function for one point ! (1) find the closest gridpoint to the target point @@ -867,7 +867,7 @@ subroutine smooth_global_function(rough_global, gamma, smooth_global) dmin = sqrt(LENGTH**2+HEIGHT**2) ! max possible distance do iglob = 1,NGLOB d = sqrt((xtar-x(iglob))**2+(ztar-z(iglob))**2) - if(d < dmin) then + if (d < dmin) then igaus = iglob dmin = d endif @@ -879,7 +879,7 @@ subroutine smooth_global_function(rough_global, gamma, smooth_global) gaus_global_ex(:) = 0.0 do iglob = 1,NGLOB dist2 = (xcen - x(iglob))**2 + (zcen - z(iglob))**2 - if(dist2 <= dtrsh2) & + if (dist2 <= dtrsh2) & gaus_global_ex(iglob) = (4./(PI*gamma**2)) * exp(-4.*dist2 / (gamma**2)) enddo @@ -901,7 +901,7 @@ subroutine smooth_global_function(rough_global, gamma, smooth_global) ! and accounts for Gaussians that are partially outside the grid. ! (4) Integrate the product of the Gaussian and the rough function. - if(HIGH_RES_SMOOTHING) then + if (HIGH_RES_SMOOTHING) then ! loop over every GLL point for high-resolution smoothing do iglob = 1,NGLOB if (mod(iglob,1000) == 0) write(*,*) iglob, ' out of ', NGLOB @@ -911,7 +911,7 @@ subroutine smooth_global_function(rough_global, gamma, smooth_global) gaus_global(:) = 0.0 do i = 1,NGLOB dist2 = (xcen - x(i))**2 + (zcen - z(i))**2 - if(dist2 <= dtrsh2) & + if (dist2 <= dtrsh2) & gaus_global(i) = (4./(PI*gamma**2)) * exp(-4.*dist2 / (gamma**2)) enddo @@ -930,7 +930,7 @@ subroutine smooth_global_function(rough_global, gamma, smooth_global) gaus_global(:) = 0.0 do i = 1,NGLOB dist2 = (xcen - x(i))**2 + (zcen - z(i))**2 - if(dist2 <= dtrsh2) & + if (dist2 <= dtrsh2) & gaus_global(i) = (4./(PI*gamma**2)) * exp(-4.*dist2 / (gamma**2)) enddo @@ -943,9 +943,9 @@ subroutine smooth_global_function(rough_global, gamma, smooth_global) ! write smooth-related functions to file ! (We can also write gaus_int_global(iglob) to file if desired.) - if(EXAMPLE_Gaussian) then + if (EXAMPLE_Gaussian) then open(unit=19,file='fun_smooth.dat',status='unknown') - if(HIGH_RES_SMOOTHING) then + if (HIGH_RES_SMOOTHING) then do iglob = 1,NGLOB write(19,'(8e16.6)') x(iglob), z(iglob), x_lon(iglob), z_lat(iglob), & rough_global(iglob), gaus_global_ex(iglob), & @@ -1051,7 +1051,7 @@ subroutine local2mvec(array1, nmod_src, source_vec, nmod, mvec) mvec(:) = 0.0 !!$ ! if the optional argument is not used, then default the factor of 1 -!!$ if(.not.present(array_fac0)) then +!!$ if (.not.present(array_fac0)) then !!$ array_fac(:,:,:) = 1. !!$ else !!$ array_fac(:,:,:) = array_fac0(:,:,:) @@ -1064,11 +1064,11 @@ subroutine local2mvec(array1, nmod_src, source_vec, nmod, mvec) do j = 1,NGLLZ do i = 1,NGLLX k = k+1 - !if(ipar==1) mvec(k) = array1(i,j,ispec) * array_fac(i,j,ispec) ! alpha - !if(ipar==2) mvec(k) = array2(i,j,ispec) * array_fac(i,j,ispec) ! beta + !if (ipar==1) mvec(k) = array1(i,j,ispec) * array_fac(i,j,ispec) ! alpha + !if (ipar==2) mvec(k) = array2(i,j,ispec) * array_fac(i,j,ispec) ! beta - if(ipar==1) mvec(k) = array1(i,j,ispec) ! btype (kappa, alpha, c) - !if(ipar==2) mvec(k) = array2(i,j,ispec) ! atype (mu, beta, beta + if (ipar==1) mvec(k) = array1(i,j,ispec) ! btype (kappa, alpha, c) + !if (ipar==2) mvec(k) = array2(i,j,ispec) ! atype (mu, beta, beta enddo enddo enddo @@ -1105,8 +1105,8 @@ subroutine mvec2local(nmod, nmod_src, mvec, array1, source_vec) do j = 1,NGLLZ do i = 1,NGLLX k = k+1 - if(ipar==1) array1(i,j,ispec) = mvec(k) ! btype (mu, beta, beta) - !if(ipar==2) array2(i,j,ispec) = mvec(k) ! atype (kappa, alpha, c) + if (ipar==1) array1(i,j,ispec) = mvec(k) ! btype (mu, beta, beta) + !if (ipar==2) array2(i,j,ispec) = mvec(k) ! atype (kappa, alpha, c) enddo enddo enddo diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d_sub2.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d_sub2.f90 index e34fa67a4..7a9d2b36a 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d_sub2.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d_sub2.f90 @@ -65,11 +65,11 @@ subroutine locate_targets(nrec, x_target, z_target, & dist = sqrt((x_target(irec) - x(iglob))**2 + (z_target(irec) - z(iglob))**2) ! keep this point if it is closer to the receiver - if(dist < dmin) then + if (dist < dmin) then dmin = dist dmin_selected_rec(irec) = dmin iglob_selected_rec(irec) = iglob ! closest gridpoint - if(i_xi_gamma) then + if (i_xi_gamma) then ispec_selected_rec(irec) = ispec ix_initial_guess(irec) = i iz_initial_guess(irec) = j @@ -92,7 +92,7 @@ subroutine locate_targets(nrec, x_target, z_target, & ! **************************************** ! if the (xi, gamma) are desired - if(i_xi_gamma) then + if (i_xi_gamma) then do irec = 1,nrec @@ -108,16 +108,16 @@ subroutine locate_targets(nrec, x_target, z_target, & !!$ ! We could also access the vectors x1,x2,z1,z2 instead. !!$ do ia = 1,NGNOD2D ! (NGNOD2D = 4) !!$ -!!$ if(ia==1) then +!!$ if (ia==1) then !!$ iax = 1 !!$ iaz = 1 -!!$ else if(ia==2) then +!!$ else if (ia==2) then !!$ iax = NGLLX !!$ iaz = 1 -!!$ else if(ia==3) then +!!$ else if (ia==3) then !!$ iax = NGLLX !!$ iaz = NGLLZ -!!$ else if(ia==4) then +!!$ else if (ia==4) then !!$ iax = 1 !!$ iaz = NGLLZ !!$ endif @@ -188,9 +188,9 @@ subroutine locate_targets(nrec, x_target, z_target, & ! display information do irec=1,nrec - if(final_distance(irec) == HUGEVAL) stop 'error locating receiver' + if (final_distance(irec) == HUGEVAL) stop 'error locating receiver' - if(0==1) then + if (0==1) then print * print *, 'target point # ', irec write(*,'(a,1f18.8)') ' target x (km) : ', x_target(irec)/1000. @@ -211,7 +211,7 @@ subroutine locate_targets(nrec, x_target, z_target, & ! add warning if estimate is poor ! (usually means receiver outside the mesh given by the user) - if(final_distance(irec) > 5.) then + if (final_distance(irec) > 5.) then print *, 'station # ',irec print *, '*******************************************************' print *, '***** WARNING: receiver location estimate is poor *****' @@ -276,7 +276,7 @@ subroutine recompute_jacobian_2d(ispec, xi, gamma, xtemp, ztemp, xix, xiz, gamma xtemp = 0.5*(1.- xi)*x1(ispec) + 0.5*(1.+ xi)*x2(ispec) ztemp = 0.5*(1.- gamma)*z1(ispec) + 0.5*(1.+gamma)*z2(ispec) - if(jacob <= 0.) stop '2D Jacobian undefined' + if (jacob <= 0.) stop '2D Jacobian undefined' end subroutine recompute_jacobian_2d @@ -302,7 +302,7 @@ subroutine lagrange_poly(xi,NGLL,xigll,h,hprime) prod1 = 1.0 prod2 = 1.0 do i=1,NGLL - if(i /= dgr) then + if (i /= dgr) then prod1 = prod1*(xi-xigll(i)) prod2 = prod2*(xigll(dgr)-xigll(i)) endif @@ -311,10 +311,10 @@ subroutine lagrange_poly(xi,NGLL,xigll,h,hprime) hprime(dgr)=0.0 do i=1,NGLL - if(i /= dgr) then + if (i /= dgr) then prod1=1.0 do j=1,NGLL - if(j /= dgr .and. j /= i) prod1 = prod1*(xi-xigll(j)) + if (j /= dgr .and. j /= i) prod1 = prod1*(xi-xigll(j)) enddo hprime(dgr) = hprime(dgr)+prod1 endif @@ -380,14 +380,14 @@ subroutine set_glob(nrec, x_rec, z_rec, rglob) print *, nrec,' input target points into set_glob.f90' - if(nrec/=0) then + if (nrec/=0) then ! find the closest gridpoint to the target point do irec = 1, nrec dmin = sqrt(LENGTH**2+HEIGHT**2) ! max possible distance do iglob = 1,NGLOB d = sqrt((x_rec(irec)-x(iglob))**2+(z_rec(irec)-z(iglob))**2) - if(d < dmin) then + if (d < dmin) then dmin = d rglob(irec) = iglob endif @@ -402,9 +402,9 @@ subroutine set_glob(nrec, x_rec, z_rec, rglob) itemp = rglob(i) iflag = 0 do j = 1,i - if(rglobtemp(j) == itemp) iflag = 1 + if (rglobtemp(j) == itemp) iflag = 1 enddo - if(iflag==0) then + if (iflag==0) then k = k+1 rglobtemp(k) = itemp endif @@ -423,7 +423,7 @@ subroutine set_glob(nrec, x_rec, z_rec, rglob) !!$ do i = 1,NGLLX !!$ iglob = ibool(i,j,ispec) !!$ d = sqrt((x_rec(irec)-x(iglob))**2+(z_rec(irec)-z(iglob))**2) -!!$ if(d < d_min_rec) then +!!$ if (d < d_min_rec) then !!$ d_min_rec = d !!$ rglob(irec) = ibool(i,j,ispec) !!$ endif @@ -478,12 +478,12 @@ subroutine station_filter(nrec, x_rec, z_rec, ifilter, dmin_trsh) !print *, xtar, ztar ! if target point is not near grid boundary - if ( xtar > (0. -dcompare) + dmin_trsh & + if ( xtar > (0. -dcompare) + dmin_trsh & .and. xtar < (LENGTH-dcompare) - dmin_trsh & .and. ztar > (0. -dcompare) + dmin_trsh & .and. ztar < (HEIGHT+dcompare) - dmin_trsh ) then - if(.not.(xtar==0. .and. ztar==0.)) then ! exclude the origin + if (.not.(xtar==0. .and. ztar==0.)) then ! exclude the origin j = j+1 !x_rec(j) = xtar @@ -495,7 +495,7 @@ subroutine station_filter(nrec, x_rec, z_rec, ifilter, dmin_trsh) !do i=1,ncoast ! ! distance from target point to coastal points ! d = sqrt((xtar-coast_x(i))**2+(ztar-coast_z(i))**2) - ! if(d < dmin) then + ! if (d < dmin) then ! dmin = d ! endif !enddo @@ -521,7 +521,7 @@ subroutine station_filter(nrec, x_rec, z_rec, ifilter, dmin_trsh) !!$ j = 0 !!$ do irec = 1, nrec !!$ d = sqrt((x(rglob(irec)) - xcen)**2+(z(rglob(irec)) - zcen)**2) -!!$ if(d > r) then +!!$ if (d > r) then !!$ j = j+1 !!$ rglob(j) = rglob(irec) !!$ endif @@ -657,7 +657,7 @@ subroutine utm_geo(rlon,rlat,rx,ry,UTM_PROJECTION_ZONE,iway) !--------------------------------------------------- - if(SUPPRESS_UTM_PROJECTION) then + if (SUPPRESS_UTM_PROJECTION) then if (iway == ILONGLAT2UTM) then rx = rlon ry = rlat diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d_sub4.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d_sub4.f90 index a9dfc3b4d..3bddc01b7 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d_sub4.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/SEM2D_iterate/src/wave2d_sub4.f90 @@ -75,7 +75,7 @@ module wave2d_sub4 !!$ ! KEY: assemble omega vector !!$ wvec(:) = 0. !!$ do j = 1,npt -!!$ if(j > npt/2) then +!!$ if (j > npt/2) then !!$ wvec(j) = dw*(j-npt-1) ! negative frequencies in second half !!$ else !!$ wvec(j) = dw*(j-1) ! positive frequencies in first half @@ -320,9 +320,9 @@ subroutine mtm_adj(ievent, nrec, syn, tstart, tend, adj_syn, data, data_recon) do i = n_left, n_right, 1 cc = 0. do j = 1, nlen - if((j+i) > 1 .and. (j+i) < nlen) cc = cc + dzr_win(j) * dzr2_win(j+i) ! cross-correlation + if ((j+i) > 1 .and. (j+i) < nlen) cc = cc + dzr_win(j) * dzr2_win(j+i) ! cross-correlation enddo - if( cc > cc_max) then + if ( cc > cc_max) then cc_max = cc ishift = i endif @@ -393,7 +393,7 @@ subroutine mtm_adj(ievent, nrec, syn, tstart, tend, adj_syn, data, data_recon) ! cross-correlation amplitude adjoint source ! You have TWO OPTIONS: measure the amplitudes based on DISPLACEMENT or VELOCITY ! Default option has been IAMP_VEL = 0 - if(IAMP_VEL == 0) then ! DISPLACEMENT + if (IAMP_VEL == 0) then ! DISPLACEMENT fa_bar_t(:) = syn_displ(:) / Mnorm dlnA = dlnAd else ! VELOCITY @@ -405,7 +405,7 @@ subroutine mtm_adj(ievent, nrec, syn, tstart, tend, adj_syn, data, data_recon) ! for now, we do not allow perturbations for the amplitude measurement dlnA_pert = dlnA - if(0==1) then + if (0==1) then !print * print *, 'cross-correlation measurments:' print *, ' dT = ', tshift_xc @@ -419,7 +419,7 @@ subroutine mtm_adj(ievent, nrec, syn, tstart, tend, adj_syn, data, data_recon) endif ! additional files for checking (measure_socal_adj.m) - if(WRITE_SEISMO_RECONSTRUCT) then + if (WRITE_SEISMO_RECONSTRUCT) then ! time domain : time, data-disp, syn-disp, syn-vel, syn-accel write(filename,'(a,i5.5,a)') 'syn_time_', irec, '.dat' open(29,file=filename,status='unknown') @@ -432,7 +432,7 @@ subroutine mtm_adj(ievent, nrec, syn, tstart, tend, adj_syn, data, data_recon) write(filename,'(a,i5.5,a)') 'xcorr_time_', irec, '.dat' open(39,file=filename,status='unknown') do i = 1,nlen - if(IAMP_VEL == 0) then + if (IAMP_VEL == 0) then write(39,'(6e18.8)') ft_bar_t(i), ft_t(i), fa_bar_t(i), fa_t(i), & -syn_accel(i)/Nnorm, -dlnAv*(-syn_accel(i)/Nnorm) else @@ -443,7 +443,7 @@ subroutine mtm_adj(ievent, nrec, syn, tstart, tend, adj_syn, data, data_recon) close(39) endif - !if(irec==4) stop 'testing' + !if (irec==4) stop 'testing' !!$ !=================================================== !!$ ! MULTITAPER MEASUREMENTS @@ -452,7 +452,7 @@ subroutine mtm_adj(ievent, nrec, syn, tstart, tend, adj_syn, data, data_recon) !!$ dtau_mtm = 0. !!$ dlnA_mtm = 0. !!$ -!!$ if(IKER==3 .or. IKER==4) then ! multitaper measurements +!!$ if (IKER==3 .or. IKER==4) then ! multitaper measurements !!$ !!$ ! calculate frequency step and number of frequencies !!$ df = 1./(npt*DT) @@ -462,7 +462,7 @@ subroutine mtm_adj(ievent, nrec, syn, tstart, tend, adj_syn, data, data_recon) !!$ ! KEY: assemble omega vector !!$ wvec(:) = 0. !!$ do j = 1,npt -!!$ if(j > npt/2) then +!!$ if (j > npt/2) then !!$ wvec(j) = dw*(j-npt-1) ! negative frequencies in second half !!$ else !!$ wvec(j) = dw*(j-1) ! positive frequencies in first half @@ -479,7 +479,7 @@ subroutine mtm_adj(ievent, nrec, syn, tstart, tend, adj_syn, data, data_recon) !!$ print *, ' shift observed seismogram by (s) : ', tshift_xc !!$ do i = 1, nlen !!$ dzr3_win(i) = 0. -!!$ if( (ishift+i) > 1 .and. (ishift+i) < nlen ) dzr3_win(i) = dzr2_win(i+ishift) +!!$ if ( (ishift+i) > 1 .and. (ishift+i) < nlen ) dzr3_win(i) = dzr2_win(i+ishift) !!$ dzr30_win(i) = dzr3_win(i) !!$ enddo !!$ @@ -532,11 +532,11 @@ subroutine mtm_adj(ievent, nrec, syn, tstart, tend, adj_syn, data, data_recon) !!$ ampmax = 0. !!$ ampmax_unw = 0. !!$ do i = 1, fnum ! loop over frequencies -!!$ if( abs(wseis(i)) > ampmax) then ! syn, single-tapered +!!$ if ( abs(wseis(i)) > ampmax) then ! syn, single-tapered !!$ ampmax = abs(wseis(i)) !!$ i_amp_max = i !!$ endif -!!$ if( abs(wseis_syn(i)) > ampmax_unw) then ! syn +!!$ if ( abs(wseis_syn(i)) > ampmax_unw) then ! syn !!$ ampmax_unw = abs(wseis_syn(i)) !!$ i_amp_max_unw = i !!$ endif @@ -552,11 +552,11 @@ subroutine mtm_adj(ievent, nrec, syn, tstart, tend, adj_syn, data, data_recon) !!$ i_right = fnum !!$ i_right_stop = 0 !!$ do i = 1,fnum ! loop over frequencies -!!$ if(i > i_amp_max_unw .and. abs(wseis_syn(i)) <= abs(wtr_use_unw) .and. i_right_stop == 0) then +!!$ if (i > i_amp_max_unw .and. abs(wseis_syn(i)) <= abs(wtr_use_unw) .and. i_right_stop == 0) then !!$ i_right_stop = 1 !!$ i_right = i !!$ endif -!!$ if(i > i_amp_max_unw .and. abs(wseis_syn(i)) >= 10.*abs(wtr_use_unw) .and. i_right_stop == 1) then +!!$ if (i > i_amp_max_unw .and. abs(wseis_syn(i)) >= 10.*abs(wtr_use_unw) .and. i_right_stop == 1) then !!$ i_right_stop = 0 !!$ i_right = i !!$ endif @@ -572,8 +572,8 @@ subroutine mtm_adj(ievent, nrec, syn, tstart, tend, adj_syn, data, data_recon) !!$ !!$ ! calculate transfer function for single taper measurement using water level !!$ ! CHT: trans IS NEVER USED HERE -!!$ !if(abs(wseis(i)) > abs(wtr_use)) trans(i) = wseis3(i) / wseis(i) -!!$ !if(abs(wseis(i)) <= abs(wtr_use)) trans(i) = wseis3(i) / (wseis(i)+wtr_use) +!!$ !if (abs(wseis(i)) > abs(wtr_use)) trans(i) = wseis3(i) / wseis(i) +!!$ !if (abs(wseis(i)) <= abs(wtr_use)) trans(i) = wseis3(i) / (wseis(i)+wtr_use) !!$ !!$ enddo ! frequencies: i = 1,fnum !!$ @@ -591,7 +591,7 @@ subroutine mtm_adj(ievent, nrec, syn, tstart, tend, adj_syn, data, data_recon) !!$ ! find water level for multi-taper measurement !!$ ampmax = 0. !!$ do i = 1, fnum -!!$ if( abs(bot_mtm(i)) > ampmax) then +!!$ if ( abs(bot_mtm(i)) > ampmax) then !!$ ampmax = abs(bot_mtm(i)) !!$ i_amp_max = i !!$ endif @@ -601,11 +601,11 @@ subroutine mtm_adj(ievent, nrec, syn, tstart, tend, adj_syn, data, data_recon) !!$ !!$ ! calculate transfer function using water level !!$ !do i = 1, fnum -!!$ ! if(abs(bot_mtm(i)) > abs(wtr_use)) trans_mtm(i) = top_mtm(i) / bot_mtm(i) -!!$ ! if(abs(bot_mtm(i)) <= abs(wtr_use)) trans_mtm(i) = top_mtm(i) / (bot_mtm(i)+wtr_use) +!!$ ! if (abs(bot_mtm(i)) > abs(wtr_use)) trans_mtm(i) = top_mtm(i) / bot_mtm(i) +!!$ ! if (abs(bot_mtm(i)) <= abs(wtr_use)) trans_mtm(i) = top_mtm(i) / (bot_mtm(i)+wtr_use) !!$ !enddo !!$ do i = 1, fnum -!!$ if(abs(bot_mtm(i)) <= abs(wtr_use)) bot_mtm(i) = bot_mtm(i) + wtr_use +!!$ if (abs(bot_mtm(i)) <= abs(wtr_use)) bot_mtm(i) = bot_mtm(i) + wtr_use !!$ enddo !!$ trans_mtm(1:fnum) = top_mtm(1:fnum) / bot_mtm(1:fnum) !!$ @@ -648,7 +648,7 @@ subroutine mtm_adj(ievent, nrec, syn, tstart, tend, adj_syn, data, data_recon) !!$ wp_taper(:) = w_taper(:) / Ffac !!$ wq_taper(:) = w_taper(:) / Ffac !!$ -!!$ if(WRITE_MTM_FILES) then +!!$ if (WRITE_MTM_FILES) then !!$ ! write transfer function to file !!$ write(filename,'(a,i5.5,a)') 'transfer_freq_', irec, '.dat' !!$ open(91,file=filename,status='unknown') @@ -672,7 +672,7 @@ subroutine mtm_adj(ievent, nrec, syn, tstart, tend, adj_syn, data, data_recon) !!$ dlnA_mtm = sum( dlnA_w(1:i_right) ) / i_right !!$ !!$ ! reconstruct data (wseis_rec) from synthetics (wseis_syn) using the transfer function (trans_mtm) -!!$ if(WRITE_SEISMO_RECONSTRUCT) then +!!$ if (WRITE_SEISMO_RECONSTRUCT) then !!$ !!$ ! Reconstruct mtm fit seismograms : syn*tran !!$ ! d(w) = s(w) T(w) exp[-i w dT] @@ -727,7 +727,7 @@ subroutine mtm_adj(ievent, nrec, syn, tstart, tend, adj_syn, data, data_recon) !!$ ! We do this by taking a function, s(t) and its time derivative, !!$ ! and then computing fourier transforms. !!$ -!!$ if(0==1) then +!!$ if (0==1) then !!$ !!$ ! create complex synthetic seismogram and complex data seismogram !!$ wseis_syn(:) = cmplx(0.,0.) @@ -747,7 +747,7 @@ subroutine mtm_adj(ievent, nrec, syn, tstart, tend, adj_syn, data, data_recon) !!$ print *, FORWARD_FFT !!$ print *, '-----------------------------' !!$ -!!$ if(1==1) then ! check Fourier convention +!!$ if (1==1) then ! check Fourier convention !!$ !!$ ! check convention -- s_d(w)*iw should give velocity !!$ do i = 1,i_right ! KEY: do not go too high frequency @@ -798,7 +798,7 @@ subroutine mtm_adj(ievent, nrec, syn, tstart, tend, adj_syn, data, data_recon) !!$ !================================================================== !!$ ! MULTITAPER ADJOINT SOURCES !!$ -!!$ !if(IKER==3 .or. IKER==4) then +!!$ !if (IKER==3 .or. IKER==4) then !!$ !!$ pw_adj(:,:) = 0. ; qw_adj(:,:) = 0. !!$ pt_adj(:,:) = 0. ; qt_adj(:,:) = 0. @@ -862,7 +862,7 @@ subroutine mtm_adj(ievent, nrec, syn, tstart, tend, adj_syn, data, data_recon) !!$ dtemp(:) = qwc_adj(:) !!$ !!$ ! EXTRA OUTPUT : IFFT into the time domain : pj(w) --> pj(t) and qj(w) --> qj(t) -!!$ if(WRITE_MTM_FILES) then +!!$ if (WRITE_MTM_FILES) then !!$ call fftinv(lnpt,pwc_adj,REVERSE_FFT,DT,pt_adj(:,ictaper)) !!$ call fftinv(lnpt,qwc_adj,REVERSE_FFT,DT,qt_adj(:,ictaper)) !!$ endif @@ -887,7 +887,7 @@ subroutine mtm_adj(ievent, nrec, syn, tstart, tend, adj_syn, data, data_recon) !!$ !!$ enddo !!$ -!!$ if(WRITE_MTM_FILES) then +!!$ if (WRITE_MTM_FILES) then !!$ ! write banana-doughnut adjoint sources to file !!$ write(filename,'(a,i5.5,a)') 'test_fadj_t_', irec, '.dat' !!$ open(21,file=filename,status='unknown') @@ -944,38 +944,38 @@ subroutine mtm_adj(ievent, nrec, syn, tstart, tend, adj_syn, data, data_recon) i1 = istart1 - 1 + i !!$ ! store the reconstructed data: d'(w) = T(w) s(w) -!!$ if(WRITE_SEISMO_RECONSTRUCT) then -!!$ if(IKER==4 .or. IKER==4) data_recon(i1,icomp,irec) = tseis_recon(i) +!!$ if (WRITE_SEISMO_RECONSTRUCT) then +!!$ if (IKER==4 .or. IKER==4) data_recon(i1,icomp,irec) = tseis_recon(i) !!$ endif - if(IKER==0) then + if (IKER==0) then adj_syn(i1,icomp,irec) = ( syn(i1,icomp,irec) - data(i1,icomp,irec) ) * time_window(i) - else if(IKER==1) then + else if (IKER==1) then adj_syn(i1,icomp,irec) = ft_t(i) * time_window(i) - else if(IKER==2) then + else if (IKER==2) then adj_syn(i1,icomp,irec) = fa_t(i) * time_window(i) - else if(IKER==3) then + else if (IKER==3) then stop 'Multitaper measurements NOT an option' !adj_syn(i1,icomp,irec) = fp(i) * time_window(i) - else if(IKER==4) then + else if (IKER==4) then stop 'Multitaper measurements NOT an option' !adj_syn(i1,icomp,irec) = fq(i) * time_window(i) - else if(IKER==5) then + else if (IKER==5) then adj_syn(i1,icomp,irec) = ft_bar_t(i) * time_window(i) - else if(IKER==6) then + else if (IKER==6) then adj_syn(i1,icomp,irec) = fa_bar_t(i) * time_window(i) endif enddo ! (1) COMPUTE MEASUREMENT VECTOR - ! (2) COMPUTE MISFIT FUNCTION (currently only for waveform, xc-tt, xc-lnA) + ! (2) COMPUTE MISFIT function (currently only for waveform, xc-tt, xc-lnA) ! IKER: (0) waveform ! (1) traveltime, cross-correlation, misfit ! (2) amplitude, cross-correlation, misfit @@ -1000,20 +1000,20 @@ subroutine mtm_adj(ievent, nrec, syn, tstart, tend, adj_syn, data, data_recon) ! NOTE THAT THE FACTOR OF 0.5 IS NOT INCLUDED HERE - if(IKER==0) then + if (IKER==0) then ! crude integration of the waveform difference chi_data(ievent,irec,icomp,1) = DT*sum( adj_syn(:,icomp,irec)**2 ) / cov_data(imeasure) - else if(IKER==1) then + else if (IKER==1) then chi_data(ievent,irec,icomp,1) = (tshift_xc_pert )**2 / cov_data(imeasure) - else if(IKER==2) then + else if (IKER==2) then chi_data(ievent,irec,icomp,1) = (dlnA_pert)**2 / cov_data(imeasure) -!!$ else if(IKER==3) then +!!$ else if (IKER==3) then !!$ chi_data(ievent,irec,icomp,1) = 2.*dw*sum( wp_taper(1:i_right) * (dtau_w(1:i_right)**2) ) !!$ -!!$ else if(IKER==4) then +!!$ else if (IKER==4) then !!$ chi_data(ievent,irec,icomp,1) = 2.*dw*sum( wq_taper(1:i_right) * (dlnA_w(1:i_right)**2) ) endif @@ -1045,7 +1045,7 @@ end subroutine mtm_adj !!$ integer :: l,iblock,nblock,i,lbhalf,j,lx !!$ !!$ ! sign must be +1. or -1. -!!$ if(zign >= 0.) then +!!$ if (zign >= 0.) then !!$ zign = 1. !!$ else !!$ zign = -1. @@ -1078,23 +1078,23 @@ end subroutine mtm_adj !!$ !!$ do 3 i=2,n !!$ ii = i -!!$ if(k < m(i)) go to 4 +!!$ if (k < m(i)) goto 4 !!$ 3 k = k-m(i) !!$ 4 k = k+m(ii) !!$ k = 0 !!$ do 7 j=1,lx -!!$ if(k < j) go to 5 +!!$ if (k < j) goto 5 !!$ hold = xi(j) !!$ xi(j) = xi(k+1) !!$ xi(k+1) = hold !!$ 5 do 6 i=1,n !!$ ii = i -!!$ if(k < m(i)) go to 7 +!!$ if (k < m(i)) goto 7 !!$ 6 k = k-m(i) !!$ 7 k = k+m(ii) !!$ !!$ ! final steps deal with dt factors -!!$ if(zign > 0.) then ! FORWARD FFT +!!$ if (zign > 0.) then ! FORWARD FFT !!$ do i = 1,lx !!$ xi(i) = xi(i)*dt ! multiplication by dt !!$ enddo @@ -1194,7 +1194,7 @@ end subroutine mtm_adj !!$ !!$ r2 = sqrt(2.) !!$ -!!$ if(nt < 2) return +!!$ if (nt < 2) return !!$ nxi=mod(nt,2) !!$ lh=(nt/2)+nxi !!$ lp1=nt+1 @@ -1204,7 +1204,7 @@ end subroutine mtm_adj !!$ do 10 i=1,lh !!$ a(i)=com*(i-hn)**2 !!$ 10 w(i)=0.5*dble(i*(nt-i)) -!!$ if(nxi == 0) then +!!$ if (nxi == 0) then !!$ asav=a(lh)-w(lh) !!$ a(lh)=a(lh)+w(lh) !!$ rbd=1./(a(lh)+w(lh-1)) @@ -1223,12 +1223,12 @@ end subroutine mtm_adj !!$ call tsturm(nt,lh,a,a(lh+1),w,neven,v,ndim,w(lh+1),0) !!$ do 20 i=1,neven !!$ k=2*i-1 -!!$ if(nxi == 1) v(lh,k)=r2*v(lh,k) +!!$ if (nxi == 1) v(lh,k)=r2*v(lh,k) !!$ do 20 j=1,lh !!$ 20 v(lp1-j,k)=v(j,k) -!!$ if(nodd <= 0) goto 34 +!!$ if (nodd <= 0) goto 34 !!$! Do the odd tapers -!!$ if(nxi == 0) then +!!$ if (nxi == 0) then !!$ a(lh)=asav*rbd !!$ else !!$ a(nt)=asav*rbd @@ -1237,7 +1237,7 @@ end subroutine mtm_adj !!$ call tsturm(nt,lh-nxi,a,a(lh+1),w,nodd,v,ndim,w(lh+1),1) !!$ do 30 i=1,nodd !!$ k=2*i -!!$ if(nxi == 1) v(lh,k)=0. +!!$ if (nxi == 1) v(lh,k)=0. !!$ do 30 j=1,lh !!$ 30 v(lp1-j,k)=-v(j,k) !!$ 34 ntot=neven+nodd @@ -1256,7 +1256,7 @@ end subroutine mtm_adj !!$ vmax=abs(v(1,m)) !!$ kmax=1 !!$ do 40 kk=2,lh -!!$ if(abs(v(kk,m)) <= vmax) goto 40 +!!$ if (abs(v(kk,m)) <= vmax) goto 40 !!$ kmax=kk !!$ vmax=abs(v(kk,m)) !!$ 40 continue @@ -1298,35 +1298,35 @@ end subroutine mtm_adj !!$ !!$ !------------------------- !!$ -!!$ if(n <= 0.or.nev <= 0) return +!!$ if (n <= 0.or.nev <= 0) return !!$ umeps=1.-epsi !!$ do 5 i=1,nev !!$ 5 ev(i)=-1. !!$ u=1. !!$ do 1000 ik=1,nev -!!$ if(ik > 1) u=ev(ik-1)*umeps +!!$ if (ik > 1) u=ev(ik-1)*umeps !!$ el=min(ev(ik),u) !!$ 10 elam=0.5*(u+el) -!!$ if(abs(u-el) <= epsi1) goto 35 +!!$ if (abs(u-el) <= epsi1) goto 35 !!$ iag=0 !!$ q=a(1)-elam -!!$ if(q >= 0.) iag=iag+1 +!!$ if (q >= 0.) iag=iag+1 !!$ do 15 i=2,n -!!$ if(q == 0.) x=abs(b(i-1))/epsi -!!$ if(q /= 0.) x=w(i-1)/q +!!$ if (q == 0.) x=abs(b(i-1))/epsi +!!$ if (q /= 0.) x=w(i-1)/q !!$ q=a(i)-elam-x -!!$ if(q >= 0.) iag=iag+1 -!!$ if(iag > nev) goto 20 +!!$ if (q >= 0.) iag=iag+1 +!!$ if (iag > nev) goto 20 !!$ 15 continue -!!$ if(iag >= ik) go to 20 +!!$ if (iag >= ik) goto 20 !!$ u=elam -!!$ go to 10 -!!$ 20 if(iag == ik) go to 30 +!!$ goto 10 +!!$ 20 if (iag == ik) goto 30 !!$ m=ik+1 !!$ do 25 i=m,iag !!$ 25 ev(i)=elam !!$ el=elam -!!$ go to 10 +!!$ goto 10 !!$ 30 el=elam !!$ call root(u,el,elam,a,b,w,n,ik) !!$ 35 ev(ik)=elam @@ -1366,30 +1366,30 @@ end subroutine mtm_adj !!$ !---------------------- !!$ !!$ 5 elam=0.5*(u+el) -!!$ 10 if(abs(u-el) <= 1.5*epsi1) return +!!$ 10 if (abs(u-el) <= 1.5*epsi1) return !!$ an=a(1)-elam !!$ b=0. !!$ bn=-1./an !!$ iag=0 -!!$ if(an >= 0.) iag=iag+1 +!!$ if (an >= 0.) iag=iag+1 !!$ do 20 i=2,n -!!$ if(an == 0.) x=abs(bb(i-1))/epsi -!!$ if(an /= 0.) x=w(i-1)/an +!!$ if (an == 0.) x=abs(bb(i-1))/epsi +!!$ if (an /= 0.) x=w(i-1)/an !!$ an=a(i)-elam-x -!!$ if(an == 0.) an=epsi +!!$ if (an == 0.) an=epsi !!$ bm=b !!$ b=bn !!$ bn=((a(i)-elam)*b-bm*x-1.)/an -!!$ if(an >= 0.) iag=iag+1 +!!$ if (an >= 0.) iag=iag+1 !!$ 20 continue -!!$ if(iag == ik) goto 25 +!!$ if (iag == ik) goto 25 !!$ u=elam !!$ goto 30 !!$ 25 el=elam !!$ 30 del=1./bn -!!$ if(abs(del) <= epsi1) del=sign(epsi1,del) +!!$ if (abs(del) <= epsi1) del=sign(epsi1,del) !!$ elam=elam-del -!!$ if(elam >= u.or.elam <= el) goto 5 +!!$ if (elam >= u.or.elam <= el) goto 5 !!$ goto 10 !!$ !!$ end subroutine root diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/cg_step/src/cg_test.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/cg_step/src/cg_test.f90 index ab49cade9..e8d0d6e31 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/cg_step/src/cg_test.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/cg_step/src/cg_test.f90 @@ -57,28 +57,28 @@ program cg_test open(unit=24,file='INPUT/volume_total',status='old',iostat=ios) read(24,*) dVfac close(24) - if(myrank==0) write(*,*) dVfac + if (myrank==0) write(*,*) dVfac ! read in the sigma value (fixed) used for the model covariance if (myrank == 0) write(*,*) 'reading in sigma_structure' open(unit=25,file='INPUT/sigma_structure',status='old',iostat=ios) read(25,*) sigma_structure close(25) - if(myrank==0) write(*,*) sigma_structure + if (myrank==0) write(*,*) sigma_structure ! read in the total number of measurement windows if (myrank == 0) write(*,*) 'reading in nwin_tot' open(unit=26,file='INPUT/nwin_tot',status='old',iostat=ios) read(26,*) nwin_tot close(26) - if(myrank==0) write(*,*) nwin_tot + if (myrank==0) write(*,*) nwin_tot ! read in the misfit value if (myrank == 0) write(*,*) 'reading in misfit function value' open(unit=27,file='INPUT/dmisfit',status='old',iostat=ios) read(27,*) dmisfit close(27) - if(myrank==0) write(*,*) dmisfit + if (myrank==0) write(*,*) dmisfit !----------------------------------------------- diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/cg_step/src/gll_library.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/cg_step/src/gll_library.f90 index 36986d6f7..d7580022f 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/cg_step/src/gll_library.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/cg_step/src/gll_library.f90 @@ -178,7 +178,7 @@ subroutine jacg (xjac,np,alpha,beta) pd = 0.d0 jmin = 0 do j=1,np - if(j == 1) then + if (j == 1) then x = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth) else x1 = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth) @@ -194,7 +194,7 @@ subroutine jacg (xjac,np,alpha,beta) enddo delx = -p/(pd-recsum*p) x = x+delx - if(abs(delx) < eps) goto 31 + if (abs(delx) < eps) goto 31 enddo 31 continue xjac(np-j+1) = x @@ -203,12 +203,12 @@ subroutine jacg (xjac,np,alpha,beta) do i=1,np xmin = 2.d0 do j=i,np - if(xjac(j) < xmin) then + if (xjac(j) < xmin) then xmin = xjac(j) jmin = j endif enddo - if(jmin /= i) then + if (jmin /= i) then swap = xjac(i) xjac(i) = xjac(jmin) xjac(jmin) = swap @@ -279,7 +279,7 @@ end subroutine jacobf !------------------------------------------------------------------------ ! - double precision FUNCTION PNDLEG (Z,N) + double precision function PNDLEG (Z,N) !------------------------------------------------------------------------ ! @@ -319,7 +319,7 @@ end function pndleg !------------------------------------------------------------------------ ! - double precision FUNCTION PNLEG (Z,N) + double precision function PNLEG (Z,N) !------------------------------------------------------------------------ ! diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_pert/src/gll_library.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_pert/src/gll_library.f90 index 36986d6f7..d7580022f 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_pert/src/gll_library.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_pert/src/gll_library.f90 @@ -178,7 +178,7 @@ subroutine jacg (xjac,np,alpha,beta) pd = 0.d0 jmin = 0 do j=1,np - if(j == 1) then + if (j == 1) then x = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth) else x1 = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth) @@ -194,7 +194,7 @@ subroutine jacg (xjac,np,alpha,beta) enddo delx = -p/(pd-recsum*p) x = x+delx - if(abs(delx) < eps) goto 31 + if (abs(delx) < eps) goto 31 enddo 31 continue xjac(np-j+1) = x @@ -203,12 +203,12 @@ subroutine jacg (xjac,np,alpha,beta) do i=1,np xmin = 2.d0 do j=i,np - if(xjac(j) < xmin) then + if (xjac(j) < xmin) then xmin = xjac(j) jmin = j endif enddo - if(jmin /= i) then + if (jmin /= i) then swap = xjac(i) xjac(i) = xjac(jmin) xjac(jmin) = swap @@ -279,7 +279,7 @@ end subroutine jacobf !------------------------------------------------------------------------ ! - double precision FUNCTION PNDLEG (Z,N) + double precision function PNDLEG (Z,N) !------------------------------------------------------------------------ ! @@ -319,7 +319,7 @@ end function pndleg !------------------------------------------------------------------------ ! - double precision FUNCTION PNLEG (Z,N) + double precision function PNLEG (Z,N) !------------------------------------------------------------------------ ! diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_slice/exit_mpi.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_slice/exit_mpi.f90 index e134dcdeb..9f6a7daf6 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_slice/exit_mpi.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_slice/exit_mpi.f90 @@ -49,7 +49,7 @@ subroutine exit_MPI(myrank,error_msg) close(IERROR) ! close output file - if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) close(IMAIN) + if (myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) close(IMAIN) ! stop all the MPI processes, and exit ! on some machines, MPI_FINALIZE needs to be called before MPI_ABORT diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_slice/locate_receivers.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_slice/locate_receivers.f90 index ce317c752..745d22036 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_slice/locate_receivers.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_slice/locate_receivers.f90 @@ -135,7 +135,7 @@ subroutine locate_receivers(ibool,myrank,NSPEC_AB,NGLOB_AB, & time_start = 0.d0 #endif - if(myrank == 0) then + if (myrank == 0) then write(IMAIN,*) write(IMAIN,*) '********************' write(IMAIN,*) ' locating receivers' @@ -146,7 +146,7 @@ subroutine locate_receivers(ibool,myrank,NSPEC_AB,NGLOB_AB, & ! define topology of the control element call usual_hex_nodes(iaddx,iaddy,iaddz) - if(myrank == 0) then + if (myrank == 0) then write(IMAIN,*) write(IMAIN,*) '*****************************************************************' write(IMAIN,'(1x,a,a,a)') 'reading receiver information from ', trim(rec_filename), ' file' @@ -158,7 +158,7 @@ subroutine locate_receivers(ibool,myrank,NSPEC_AB,NGLOB_AB, & if (ios /= 0) call exit_mpi(myrank,'error opening file '//trim(rec_filename)) read(1,*) nrec_dummy - if(nrec_dummy /= nrec) call exit_MPI(myrank,'problem with number of receivers') + if (nrec_dummy /= nrec) call exit_MPI(myrank,'problem with number of receivers') ! allocate memory for arrays using number of stations allocate(stlat(nrec)) @@ -206,7 +206,7 @@ subroutine locate_receivers(ibool,myrank,NSPEC_AB,NGLOB_AB, & horiz_dist(irec) = dsqrt((stutm_y(irec)-utm_y_source)**2 + (stutm_x(irec)-utm_x_source)**2) / 1000. ! print some information about stations - if(myrank == 0) & + if (myrank == 0) & write(IMAIN,*) 'Station #',irec,': ',station_name(irec)(1:len_trim(station_name(irec))), & '.',network_name(irec)(1:len_trim(network_name(irec))), & ' horizontal distance: ',sngl(horiz_dist(irec)),' km' @@ -232,17 +232,17 @@ subroutine locate_receivers(ibool,myrank,NSPEC_AB,NGLOB_AB, & ! compute elevation of topography at the receiver location ! we assume that receivers are always at the surface i.e. not buried - if(TOPOGRAPHY) then + if (TOPOGRAPHY) then ! get coordinate of corner in bathy/topo model icornerlong = int((stlon(irec) - ORIG_LONG_TOPO) / DEGREES_PER_CELL_TOPO) + 1 icornerlat = int((stlat(irec) - ORIG_LAT_TOPO) / DEGREES_PER_CELL_TOPO) + 1 ! avoid edge effects and extend with identical point if outside model - if(icornerlong < 1) icornerlong = 1 - if(icornerlong > NX_TOPO-1) icornerlong = NX_TOPO-1 - if(icornerlat < 1) icornerlat = 1 - if(icornerlat > NY_TOPO-1) icornerlat = NY_TOPO-1 + if (icornerlong < 1) icornerlong = 1 + if (icornerlong > NX_TOPO-1) icornerlong = NX_TOPO-1 + if (icornerlat < 1) icornerlat = 1 + if (icornerlat > NY_TOPO-1) icornerlat = NY_TOPO-1 ! compute coordinates of corner long_corner = ORIG_LONG_TOPO + (icornerlong-1)*DEGREES_PER_CELL_TOPO @@ -253,10 +253,10 @@ subroutine locate_receivers(ibool,myrank,NSPEC_AB,NGLOB_AB, & ratio_eta = (stlat(irec) - lat_corner) / DEGREES_PER_CELL_TOPO ! avoid edge effects - if(ratio_xi < 0.) ratio_xi = 0. - if(ratio_xi > 1.) ratio_xi = 1. - if(ratio_eta < 0.) ratio_eta = 0. - if(ratio_eta > 1.) ratio_eta = 1. + if (ratio_xi < 0.) ratio_xi = 0. + if (ratio_xi > 1.) ratio_xi = 1. + if (ratio_eta < 0.) ratio_eta = 0. + if (ratio_eta > 1.) ratio_eta = 1. ! interpolate elevation at current point elevation = & @@ -295,7 +295,7 @@ subroutine locate_receivers(ibool,myrank,NSPEC_AB,NGLOB_AB, & +(z_target(irec)-dble(zstore(iglob)))**2) ! keep this point if it is closer to the receiver - if(dist < distmin) then + if (dist < distmin) then distmin = dist ispec_selected_rec(irec) = ispec ix_initial_guess(irec) = i @@ -335,31 +335,31 @@ subroutine locate_receivers(ibool,myrank,NSPEC_AB,NGLOB_AB, & do ia=1,NGNOD - if(iaddx(ia) == 0) then + if (iaddx(ia) == 0) then iax = 1 - else if(iaddx(ia) == 1) then + else if (iaddx(ia) == 1) then iax = (NGLLX+1)/2 - else if(iaddx(ia) == 2) then + else if (iaddx(ia) == 2) then iax = NGLLX else call exit_MPI(myrank,'incorrect value of iaddx') endif - if(iaddy(ia) == 0) then + if (iaddy(ia) == 0) then iay = 1 - else if(iaddy(ia) == 1) then + else if (iaddy(ia) == 1) then iay = (NGLLY+1)/2 - else if(iaddy(ia) == 2) then + else if (iaddy(ia) == 2) then iay = NGLLY else call exit_MPI(myrank,'incorrect value of iaddy') endif - if(iaddz(ia) == 0) then + if (iaddz(ia) == 0) then iaz = 1 - else if(iaddz(ia) == 1) then + else if (iaddz(ia) == 1) then iaz = (NGLLZ+1)/2 - else if(iaddz(ia) == 2) then + else if (iaddz(ia) == 2) then iaz = NGLLZ else call exit_MPI(myrank,'incorrect value of iaddz') @@ -464,17 +464,17 @@ subroutine locate_receivers(ibool,myrank,NSPEC_AB,NGLOB_AB, & #endif ! this is executed by main process only - if(myrank == 0) then + if (myrank == 0) then ! check that the gather operation went well - if(any(ispec_selected_rec_all(:,:) == -1)) call exit_MPI(myrank,'gather operation failed for receivers') + if (any(ispec_selected_rec_all(:,:) == -1)) call exit_MPI(myrank,'gather operation failed for receivers') ! MPI loop on all the results to determine the best slice islice_selected_rec(:) = -1 do irec = 1,nrec distmin = HUGEVAL do iprocloop = 0,NPROC-1 - if(final_distance_all(irec,iprocloop) < distmin) then + if (final_distance_all(irec,iprocloop) < distmin) then distmin = final_distance_all(irec,iprocloop) islice_selected_rec(irec) = iprocloop ispec_selected_rec(irec) = ispec_selected_rec_all(irec,iprocloop) @@ -494,14 +494,14 @@ subroutine locate_receivers(ibool,myrank,NSPEC_AB,NGLOB_AB, & write(IMAIN,*) write(IMAIN,*) 'station # ',irec,' ',station_name(irec),network_name(irec) - if(final_distance(irec) == HUGEVAL) call exit_MPI(myrank,'error locating receiver') + if (final_distance(irec) == HUGEVAL) call exit_MPI(myrank,'error locating receiver') write(IMAIN,*) ' original latitude: ',sngl(stlat(irec)) write(IMAIN,*) ' original longitude: ',sngl(stlon(irec)) write(IMAIN,*) ' original UTM x: ',sngl(stutm_x(irec)) write(IMAIN,*) ' original UTM y: ',sngl(stutm_y(irec)) write(IMAIN,*) ' horizontal distance: ',sngl(horiz_dist(irec)) - if(TOPOGRAPHY) write(IMAIN,*) ' topography elevation: ',sngl(elevation(irec)) + if (TOPOGRAPHY) write(IMAIN,*) ' topography elevation: ',sngl(elevation(irec)) write(IMAIN,*) ' target x, y, z: ',sngl(x_target(irec)),sngl(y_target(irec)),sngl(z_target(irec)) write(IMAIN,*) 'closest estimate found: ',sngl(final_distance(irec)),' m away' @@ -510,7 +510,7 @@ subroutine locate_receivers(ibool,myrank,NSPEC_AB,NGLOB_AB, & ! add warning if estimate is poor ! (usually means receiver outside the mesh given by the user) - if(final_distance(irec) > 3000.d0) then + if (final_distance(irec) > 3000.d0) then write(IMAIN,*) '*******************************************************' write(IMAIN,*) '***** WARNING: receiver location estimate is poor *****' write(IMAIN,*) '*******************************************************' @@ -528,7 +528,7 @@ subroutine locate_receivers(ibool,myrank,NSPEC_AB,NGLOB_AB, & ! add warning if estimate is poor ! (usually means receiver outside the mesh given by the user) - if(final_distance_max > 1000.d0) then + if (final_distance_max > 1000.d0) then write(IMAIN,*) write(IMAIN,*) '************************************************************' write(IMAIN,*) '************************************************************' @@ -632,7 +632,7 @@ subroutine station_filter(myrank,filename,filtered_filename,nfilter, & read(IIN, *) nrec do irec = 1, nrec read(IIN, *) station_name, network_name, stlat, stlon, stele, stbur - if(stlat >= LATITUDE_MIN .and. stlat <= LATITUDE_MAX .and. stlon >= LONGITUDE_MIN .and. stlon <= LONGITUDE_MAX) & + if (stlat >= LATITUDE_MIN .and. stlat <= LATITUDE_MAX .and. stlon >= LONGITUDE_MIN .and. stlon <= LONGITUDE_MAX) & nrec_filtered = nrec_filtered + 1 enddo close(IIN) @@ -644,7 +644,7 @@ subroutine station_filter(myrank,filename,filtered_filename,nfilter, & write(IOUT,*) nrec_filtered do irec = 1,nrec read(IIN,*) station_name,network_name,stlat,stlon,stele,stbur - if(stlat >= LATITUDE_MIN .and. stlat <= LATITUDE_MAX .and. stlon >= LONGITUDE_MIN .and. stlon <= LONGITUDE_MAX) & + if (stlat >= LATITUDE_MIN .and. stlat <= LATITUDE_MAX .and. stlon >= LONGITUDE_MIN .and. stlon <= LONGITUDE_MAX) & write(IOUT,*) station_name,' ',network_name,' ',sngl(stlat),' ',sngl(stlon), ' ',sngl(stele), ' ',sngl(stbur) enddo close(IIN) diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_slice/sem_model_slice.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_slice/sem_model_slice.f90 index 6f5c128aa..8091ae051 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_slice/sem_model_slice.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_slice/sem_model_slice.f90 @@ -94,7 +94,7 @@ program sem_model_slice +(y(1:npts)-dble(ystore(iglob)))**2 & +(z(1:npts)-dble(zstore(iglob)))**2) do ipt=1,npts - if(dist(ipt) < distmin(ipt)) then + if (dist(ipt) < distmin(ipt)) then distmin(ipt)=dist(ipt) ispec_min(ipt)=ispec ix_min(ipt)=i; iy_min(ipt)=j; iz_min(ipt)=k @@ -127,7 +127,7 @@ program sem_model_slice enddo call MPI_REDUCE(in,out,npts,CUSTOM_MPI_2REAL,MPI_MINLOC,0,MPI_COMM_WORLD,ier) - ! if (myrank == 0) then + ! if (myrank == 0) then ! open(33,file='OUTPUT_FILES/out.txt') ! do i = 1, npts ! write(33,*) i, out(1,i), out(2,i) @@ -200,10 +200,10 @@ subroutine topo_value(itopo_bathy_basin,x,y,elevation) icornerlat = int((lat - ORIG_LAT_TOPO_SOCAL) / DEGREES_PER_CELL_TOPO_SOCAL) + 1 ! avoid edge effects and extend with identical point if outside model - if(icornerlong < 1) icornerlong = 1 - if(icornerlong > NX_TOPO_SOCAL-1) icornerlong = NX_TOPO_SOCAL-1 - if(icornerlat < 1) icornerlat = 1 - if(icornerlat > NY_TOPO_SOCAL-1) icornerlat = NY_TOPO_SOCAL-1 + if (icornerlong < 1) icornerlong = 1 + if (icornerlong > NX_TOPO_SOCAL-1) icornerlong = NX_TOPO_SOCAL-1 + if (icornerlat < 1) icornerlat = 1 + if (icornerlat > NY_TOPO_SOCAL-1) icornerlat = NY_TOPO_SOCAL-1 ! compute coordinates of corner long_corner = ORIG_LONG_TOPO_SOCAL + (icornerlong-1)*DEGREES_PER_CELL_TOPO_SOCAL @@ -214,10 +214,10 @@ subroutine topo_value(itopo_bathy_basin,x,y,elevation) ratio_eta = (lat - lat_corner) / DEGREES_PER_CELL_TOPO_SOCAL ! avoid edge effects - if(ratio_xi < 0.) ratio_xi = 0. - if(ratio_xi > 1.) ratio_xi = 1. - if(ratio_eta < 0.) ratio_eta = 0. - if(ratio_eta > 1.) ratio_eta = 1. + if (ratio_xi < 0.) ratio_xi = 0. + if (ratio_xi > 1.) ratio_xi = 1. + if (ratio_eta < 0.) ratio_eta = 0. + if (ratio_eta > 1.) ratio_eta = 1. ! interpolate elevation at current point elevation = & diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_slice/utm_geo.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_slice/utm_geo.f90 index 8e78f9c53..3bbc01a55 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_slice/utm_geo.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_slice/utm_geo.f90 @@ -49,7 +49,7 @@ subroutine utm_geo(rlon,rlat,rx,ry,UTM_PROJECTION_ZONE,iway,SUPPRESS_UTM_PROJECT double precision f1,f2,f3,f4,rm,rn,t,c,a,e1,u,rlat1,dlat1,c1,t1,rn1,r1,d double precision rx_save,ry_save,rlon_save,rlat_save - if(SUPPRESS_UTM_PROJECTION) then + if (SUPPRESS_UTM_PROJECTION) then if (iway == ILONGLAT2UTM) then rx = rlon ry = rlat diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_vp_vs/src/add_model.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_vp_vs/src/add_model.f90 index 4cf5a7409..105f81a96 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_vp_vs/src/add_model.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_vp_vs/src/add_model.f90 @@ -43,7 +43,7 @@ program add_model write(20,'(1e24.12)') step_fac close(20) - if(MINMAX_THRESHOLD_OLD .or. MINMAX_THRESHOLD_NEW) then + if (MINMAX_THRESHOLD_OLD .or. MINMAX_THRESHOLD_NEW) then ! minmax wavespeed values for southern california simulations VS_MIN = 600.0 VS_MAX = 4700.0 @@ -129,15 +129,15 @@ program add_model endif ! threshold current model and write out the modified version - if(MINMAX_THRESHOLD_OLD) then + if (MINMAX_THRESHOLD_OLD) then do ispec=1,NSPEC do k=1,NGLLZ do j=1,NGLLY do i=1,NGLLX - if(model_vs(i,j,k,ispec) < VS_MIN) model_vs(i,j,k,ispec) = VS_MIN - if(model_vs(i,j,k,ispec) > VS_MAX) model_vs(i,j,k,ispec) = VS_MAX - if(model_vp(i,j,k,ispec) < VP_MIN) model_vp(i,j,k,ispec) = VP_MIN - if(model_vp(i,j,k,ispec) > VP_MAX) model_vp(i,j,k,ispec) = VP_MAX + if (model_vs(i,j,k,ispec) < VS_MIN) model_vs(i,j,k,ispec) = VS_MIN + if (model_vs(i,j,k,ispec) > VS_MAX) model_vs(i,j,k,ispec) = VS_MAX + if (model_vp(i,j,k,ispec) < VP_MIN) model_vp(i,j,k,ispec) = VP_MIN + if (model_vp(i,j,k,ispec) > VP_MAX) model_vp(i,j,k,ispec) = VP_MAX enddo enddo enddo @@ -214,15 +214,15 @@ program add_model !----------------------------------------------------- ! threshold model according to minmax values specified above - if(MINMAX_THRESHOLD_NEW) then + if (MINMAX_THRESHOLD_NEW) then do ispec=1,NSPEC do k=1,NGLLZ do j=1,NGLLY do i=1,NGLLX - if(model_vs_new(i,j,k,ispec) < VS_MIN) model_vs_new(i,j,k,ispec) = VS_MIN - if(model_vs_new(i,j,k,ispec) > VS_MAX) model_vs_new(i,j,k,ispec) = VS_MAX - if(model_vp_new(i,j,k,ispec) < VP_MIN) model_vp_new(i,j,k,ispec) = VP_MIN - if(model_vp_new(i,j,k,ispec) > VP_MAX) model_vp_new(i,j,k,ispec) = VP_MAX + if (model_vs_new(i,j,k,ispec) < VS_MIN) model_vs_new(i,j,k,ispec) = VS_MIN + if (model_vs_new(i,j,k,ispec) > VS_MAX) model_vs_new(i,j,k,ispec) = VS_MAX + if (model_vp_new(i,j,k,ispec) < VP_MIN) model_vp_new(i,j,k,ispec) = VP_MIN + if (model_vp_new(i,j,k,ispec) > VP_MAX) model_vp_new(i,j,k,ispec) = VP_MAX enddo enddo enddo diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_vp_vs/src/gll_library.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_vp_vs/src/gll_library.f90 index 36986d6f7..d7580022f 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_vp_vs/src/gll_library.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/model_vp_vs/src/gll_library.f90 @@ -178,7 +178,7 @@ subroutine jacg (xjac,np,alpha,beta) pd = 0.d0 jmin = 0 do j=1,np - if(j == 1) then + if (j == 1) then x = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth) else x1 = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth) @@ -194,7 +194,7 @@ subroutine jacg (xjac,np,alpha,beta) enddo delx = -p/(pd-recsum*p) x = x+delx - if(abs(delx) < eps) goto 31 + if (abs(delx) < eps) goto 31 enddo 31 continue xjac(np-j+1) = x @@ -203,12 +203,12 @@ subroutine jacg (xjac,np,alpha,beta) do i=1,np xmin = 2.d0 do j=i,np - if(xjac(j) < xmin) then + if (xjac(j) < xmin) then xmin = xjac(j) jmin = j endif enddo - if(jmin /= i) then + if (jmin /= i) then swap = xjac(i) xjac(i) = xjac(jmin) xjac(jmin) = swap @@ -279,7 +279,7 @@ end subroutine jacobf !------------------------------------------------------------------------ ! - double precision FUNCTION PNDLEG (Z,N) + double precision function PNDLEG (Z,N) !------------------------------------------------------------------------ ! @@ -319,7 +319,7 @@ end function pndleg !------------------------------------------------------------------------ ! - double precision FUNCTION PNLEG (Z,N) + double precision function PNLEG (Z,N) !------------------------------------------------------------------------ ! diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/smooth/src/gll_library.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/smooth/src/gll_library.f90 index 36986d6f7..d7580022f 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/smooth/src/gll_library.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/smooth/src/gll_library.f90 @@ -178,7 +178,7 @@ subroutine jacg (xjac,np,alpha,beta) pd = 0.d0 jmin = 0 do j=1,np - if(j == 1) then + if (j == 1) then x = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth) else x1 = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth) @@ -194,7 +194,7 @@ subroutine jacg (xjac,np,alpha,beta) enddo delx = -p/(pd-recsum*p) x = x+delx - if(abs(delx) < eps) goto 31 + if (abs(delx) < eps) goto 31 enddo 31 continue xjac(np-j+1) = x @@ -203,12 +203,12 @@ subroutine jacg (xjac,np,alpha,beta) do i=1,np xmin = 2.d0 do j=i,np - if(xjac(j) < xmin) then + if (xjac(j) < xmin) then xmin = xjac(j) jmin = j endif enddo - if(jmin /= i) then + if (jmin /= i) then swap = xjac(i) xjac(i) = xjac(jmin) xjac(jmin) = swap @@ -279,7 +279,7 @@ end subroutine jacobf !------------------------------------------------------------------------ ! - double precision FUNCTION PNDLEG (Z,N) + double precision function PNDLEG (Z,N) !------------------------------------------------------------------------ ! @@ -319,7 +319,7 @@ end function pndleg !------------------------------------------------------------------------ ! - double precision FUNCTION PNLEG (Z,N) + double precision function PNLEG (Z,N) !------------------------------------------------------------------------ ! diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/subspace_hessian/src/gll_library.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/subspace_hessian/src/gll_library.f90 index 36986d6f7..d7580022f 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/subspace_hessian/src/gll_library.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/subspace_hessian/src/gll_library.f90 @@ -178,7 +178,7 @@ subroutine jacg (xjac,np,alpha,beta) pd = 0.d0 jmin = 0 do j=1,np - if(j == 1) then + if (j == 1) then x = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth) else x1 = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth) @@ -194,7 +194,7 @@ subroutine jacg (xjac,np,alpha,beta) enddo delx = -p/(pd-recsum*p) x = x+delx - if(abs(delx) < eps) goto 31 + if (abs(delx) < eps) goto 31 enddo 31 continue xjac(np-j+1) = x @@ -203,12 +203,12 @@ subroutine jacg (xjac,np,alpha,beta) do i=1,np xmin = 2.d0 do j=i,np - if(xjac(j) < xmin) then + if (xjac(j) < xmin) then xmin = xjac(j) jmin = j endif enddo - if(jmin /= i) then + if (jmin /= i) then swap = xjac(i) xjac(i) = xjac(jmin) xjac(jmin) = swap @@ -279,7 +279,7 @@ end subroutine jacobf !------------------------------------------------------------------------ ! - double precision FUNCTION PNDLEG (Z,N) + double precision function PNDLEG (Z,N) !------------------------------------------------------------------------ ! @@ -319,7 +319,7 @@ end function pndleg !------------------------------------------------------------------------ ! - double precision FUNCTION PNLEG (Z,N) + double precision function PNLEG (Z,N) !------------------------------------------------------------------------ ! diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/subspace_hessian/src/subspace_hessian.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/subspace_hessian/src/subspace_hessian.f90 index d5f9a0b17..5329ee9fc 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/subspace_hessian/src/subspace_hessian.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/subspace_hessian/src/subspace_hessian.f90 @@ -66,7 +66,7 @@ program subspace_hessian read(12,*) ismooth close(12) - if(ismooth == 1) then + if (ismooth == 1) then kernel_name1 = 'mu_kernel_smooth' kernel_name2 = 'kappa_kernel_smooth' else @@ -99,7 +99,7 @@ program subspace_hessian !!$ open(unit=20,file=trim(win_file),status='old',iostat=ios) !!$ do i=1,nsrc !!$ read(20,*) nwin_vec(i) -!!$ if(myrank==0) write(*,*) nwin_vec(i) +!!$ if (myrank==0) write(*,*) nwin_vec(i) !!$ enddo !!$ close(20) diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/subspace_update/src/gll_library.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/subspace_update/src/gll_library.f90 index 36986d6f7..d7580022f 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/subspace_update/src/gll_library.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/subspace_update/src/gll_library.f90 @@ -178,7 +178,7 @@ subroutine jacg (xjac,np,alpha,beta) pd = 0.d0 jmin = 0 do j=1,np - if(j == 1) then + if (j == 1) then x = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth) else x1 = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth) @@ -194,7 +194,7 @@ subroutine jacg (xjac,np,alpha,beta) enddo delx = -p/(pd-recsum*p) x = x+delx - if(abs(delx) < eps) goto 31 + if (abs(delx) < eps) goto 31 enddo 31 continue xjac(np-j+1) = x @@ -203,12 +203,12 @@ subroutine jacg (xjac,np,alpha,beta) do i=1,np xmin = 2.d0 do j=i,np - if(xjac(j) < xmin) then + if (xjac(j) < xmin) then xmin = xjac(j) jmin = j endif enddo - if(jmin /= i) then + if (jmin /= i) then swap = xjac(i) xjac(i) = xjac(jmin) xjac(jmin) = swap @@ -279,7 +279,7 @@ end subroutine jacobf !------------------------------------------------------------------------ ! - double precision FUNCTION PNDLEG (Z,N) + double precision function PNDLEG (Z,N) !------------------------------------------------------------------------ ! @@ -319,7 +319,7 @@ end function pndleg !------------------------------------------------------------------------ ! - double precision FUNCTION PNLEG (Z,N) + double precision function PNLEG (Z,N) !------------------------------------------------------------------------ ! diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/subspace_update/src/subspace_update.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/subspace_update/src/subspace_update.f90 index 8dbeaa55c..f7c71589c 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/subspace_update/src/subspace_update.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/subspace_update/src/subspace_update.f90 @@ -48,7 +48,7 @@ program subspace_update read(20,*) kernel_name close(20) - if(myrank==0) then + if (myrank==0) then write(*,*) 'dcov_tag : ', trim(dcov_tag) write(*,*) 'kernel_name : ', trim(kernel_name) @@ -87,7 +87,7 @@ program subspace_update enddo close(19) - if(myrank == 0) then + if (myrank == 0) then write(*,*) 'total number of events (and kernels) : ',nsrc write(*,*) (kernel_list(isrc),isrc=1,nsrc) endif @@ -100,7 +100,7 @@ program subspace_update open(unit=22,file=trim(idir)//'data_norm',status='old',iostat=ios) do i=1,nsrc read(22,*) dnorm(i) - if(myrank==0) write(*,*) dnorm(i) + if (myrank==0) write(*,*) dnorm(i) enddo close(22) @@ -109,7 +109,7 @@ program subspace_update open(unit=23,file=trim(idir)//'dcov_fac',status='old',iostat=ios) do i=1,nsrc read(23,*) dcov_fac(i) - if(myrank==0) write(*,*) dcov_fac(i) + if (myrank==0) write(*,*) dcov_fac(i) enddo close(23) @@ -118,14 +118,14 @@ program subspace_update open(unit=24,file='INPUT/dVfac',status='old',iostat=ios) read(24,*) dVfac close(24) - if(myrank==0) write(*,*) dVfac + if (myrank==0) write(*,*) dVfac ! read in the sigma value (fixed) used for the model covariance if (myrank == 0) write(*,*) 'reading in sigma_structure' open(unit=25,file='INPUT/sigma_structure',status='old',iostat=ios) read(25,*) sigma_structure close(25) - if(myrank==0) write(*,*) sigma_structure + if (myrank==0) write(*,*) sigma_structure !--------------------------------------------------- @@ -145,7 +145,7 @@ program subspace_update enddo close(19) - if(myrank == 0) then + if (myrank == 0) then write(*,*) 'total number of pmax update models : ',npmax write(*,*) (pmax_list(i),i=1,npmax) endif @@ -156,7 +156,7 @@ program subspace_update read(26,*) (lambdas(p),p=1,npmax) close(26) - if(myrank == 0) then + if (myrank == 0) then write(*,*) (lambdas(p),p=1,npmax) endif @@ -175,7 +175,7 @@ program subspace_update open(unit=20,file=trim(filename),status='old',iostat=ios) do i=1,nsrc read(20,*) mu_beta(i) - if(myrank==0) write(*,*) mu_beta(i) + if (myrank==0) write(*,*) mu_beta(i) enddo close(20) diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/sum_kernel/src/exit_mpi.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/sum_kernel/src/exit_mpi.f90 index 160ca3cd8..3ecac6089 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/sum_kernel/src/exit_mpi.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/sum_kernel/src/exit_mpi.f90 @@ -58,7 +58,7 @@ subroutine exit_MPI(myrank,error_msg) close(IERROR) ! close output file -! if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) close(IMAIN) +! if (myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) close(IMAIN) ! call stop_all() call MPI_FINALIZE(ier) call MPI_ABORT(ier) diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/sum_kernel/src/sum_kernels.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/sum_kernel/src/sum_kernels.f90 index 8f3c1dfa0..fabbb2bcf 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/sum_kernel/src/sum_kernels.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/sum_kernel/src/sum_kernels.f90 @@ -58,7 +58,7 @@ program sum_kernels total_kernel=0. do iker = 1, nker - if(myrank==1) write(*,*) 'reading in event kernel for mu: ', iker, ' out of ', nker + if (myrank==1) write(*,*) 'reading in event kernel for mu: ', iker, ' out of ', nker write(k_file,'(a,i6.6,a)') 'INPUT_KERNELS/'//trim(kernel_list(iker))//'/proc',myrank,'_'//trim(kernel_name)//'.bin' open(12,file=trim(k_file),status='old',form='unformatted') @@ -69,7 +69,7 @@ program sum_kernels total_kernel(:,:,:,1:nspec) = total_kernel(:,:,:,1:nspec) + kernel(:,:,:,1:nspec) enddo - if(myrank==1) write(*,*) 'writing out summed kernel for mu' + if (myrank==1) write(*,*) 'writing out summed kernel for mu' write(k_file,'(a,i6.6,a)') 'OUTPUT_SUM/proc',myrank,'_'//trim(kernel_name)//'.bin' open(12,file=trim(k_file),form='unformatted') write(12) total_kernel(:,:,:,1:nspec) @@ -80,7 +80,7 @@ program sum_kernels !!$ !!$ total_kernel=0. !!$ do iker = 1, nker -!!$ if(myrank==1) write(*,*) 'reading in event kernel for kappa: ', iker, ' out of ', nker +!!$ if (myrank==1) write(*,*) 'reading in event kernel for kappa: ', iker, ' out of ', nker !!$ write(k_file,'(a,i6.6,a)') 'INPUT_KERNELS/'//trim(kernel_list(iker))//'/proc',myrank,'_'//trim(kernel_name)//'.bin' !!$ !!$ open(12,file=trim(k_file),status='old',form='unformatted') @@ -91,13 +91,13 @@ program sum_kernels !!$ total_kernel(:,:,:,1:nspec) = total_kernel(:,:,:,1:nspec) + kernel(:,:,:,1:nspec) !!$ !!$ enddo -!!$ if(myrank==1) write(*,*) 'writing out summed kernel for kappa' +!!$ if (myrank==1) write(*,*) 'writing out summed kernel for kappa' !!$ write(k_file,'(a,i6.6,a)') 'OUTPUT_SUM/proc',myrank,'_'//trim(kernel_name)//'.bin' !!$ open(12,file=trim(k_file),form='unformatted') !!$ write(12) total_kernel(:,:,:,1:nspec) !!$ close(12) - if(myrank==1) write(*,*) 'done writing all kernels, now finishing...' + if (myrank==1) write(*,*) 'done writing all kernels, now finishing...' ! stop all the MPI processes, and exit call MPI_FINALIZE(ier) diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/sum_kernel/src/sum_kernels_weight.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/sum_kernel/src/sum_kernels_weight.f90 index 95b469cfd..ee99dd36b 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/sum_kernel/src/sum_kernels_weight.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/sum_kernel/src/sum_kernels_weight.f90 @@ -59,7 +59,7 @@ program sum_kernels close(20) !do iker = 1, nker - ! if(myrank==1) write(*,*) 'Kernel, nwin: ', trim(kernel_list(iker)), ' out of ', nwin_list(iker) + ! if (myrank==1) write(*,*) 'Kernel, nwin: ', trim(kernel_list(iker)), ' out of ', nwin_list(iker) !enddo !------------------------------------------------------ @@ -69,7 +69,7 @@ program sum_kernels total_kernel=0. do iker = 1, nker - if(myrank==1) write(*,*) 'reading in event kernel for mu: ', iker, ' out of ', nker + if (myrank==1) write(*,*) 'reading in event kernel for mu: ', iker, ' out of ', nker write(k_file,'(a,i6.6,a)') 'INPUT_KERNELS/'//trim(kernel_list(iker))//'/proc',myrank,'_'//trim(kernel_name)//'.bin' open(12,file=trim(k_file),status='old',form='unformatted') @@ -81,7 +81,7 @@ program sum_kernels total_kernel(:,:,:,1:nspec) = total_kernel(:,:,:,1:nspec) + 1.0/dble(nwin_list(iker)) * abs( kernel(:,:,:,1:nspec) ) enddo - if(myrank==1) write(*,*) 'writing out summed kernel for mu' + if (myrank==1) write(*,*) 'writing out summed kernel for mu' write(k_file,'(a,i6.6,a)') 'OUTPUT_SUM/proc',myrank,'_'//trim(kernel_name)//'.bin' open(12,file=trim(k_file),form='unformatted') write(12) total_kernel(:,:,:,1:nspec) @@ -92,7 +92,7 @@ program sum_kernels total_kernel=0. do iker = 1, nker - if(myrank==1) write(*,*) 'reading in event kernel for kappa: ', iker, ' out of ', nker + if (myrank==1) write(*,*) 'reading in event kernel for kappa: ', iker, ' out of ', nker write(k_file,'(a,i6.6,a)') 'INPUT_KERNELS/'//trim(kernel_list(iker))//'/proc',myrank,'_'//trim(kernel_name)//'.bin' open(12,file=trim(k_file),status='old',form='unformatted') @@ -104,13 +104,13 @@ program sum_kernels total_kernel(:,:,:,1:nspec) = total_kernel(:,:,:,1:nspec) + 1.0/dble(nwin_list(iker)) * abs( kernel(:,:,:,1:nspec) ) enddo - if(myrank==1) write(*,*) 'writing out summed kernel for kappa' + if (myrank==1) write(*,*) 'writing out summed kernel for kappa' write(k_file,'(a,i6.6,a)') 'OUTPUT_SUM/proc',myrank,'_'//trim(kernel_name)//'.bin' open(12,file=trim(k_file),form='unformatted') write(12) total_kernel(:,:,:,1:nspec) close(12) - if(myrank==1) write(*,*) 'done writing all kernels, now finishing...' + if (myrank==1) write(*,*) 'done writing all kernels, now finishing...' ! stop all the MPI processes, and exit call MPI_FINALIZE(ier) diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/topo_input/combine_vol_data/combine_vol_data_mod.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/topo_input/combine_vol_data/combine_vol_data_mod.f90 index 2cf36a458..a9b90a56c 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/topo_input/combine_vol_data/combine_vol_data_mod.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/iterate_adj/cluster/topo_input/combine_vol_data/combine_vol_data_mod.f90 @@ -173,7 +173,7 @@ program combine_paraview_data iglob7=ibool(NGLLX,NGLLY,NGLLZ,ispec) iglob8=ibool(1,NGLLY,NGLLZ,ispec) - if(.not. mask_ibool(iglob1)) then + if (.not. mask_ibool(iglob1)) then numpoin = numpoin + 1 read(25,*) njunk, x, y, z call write_real(x) @@ -182,7 +182,7 @@ program combine_paraview_data call write_real(dat(1,1,1,ispec)) mask_ibool(iglob1) = .true. endif - if(.not. mask_ibool(iglob2)) then + if (.not. mask_ibool(iglob2)) then numpoin = numpoin + 1 read(25,*) njunk, x, y, z call write_real(x) @@ -191,7 +191,7 @@ program combine_paraview_data call write_real(dat(NGLLX,1,1,ispec)) mask_ibool(iglob2) = .true. endif - if(.not. mask_ibool(iglob3)) then + if (.not. mask_ibool(iglob3)) then numpoin = numpoin + 1 read(25,*) njunk, x, y, z call write_real(x) @@ -200,7 +200,7 @@ program combine_paraview_data call write_real(dat(NGLLX,NGLLY,1,ispec)) mask_ibool(iglob3) = .true. endif - if(.not. mask_ibool(iglob4)) then + if (.not. mask_ibool(iglob4)) then numpoin = numpoin + 1 read(25,*) njunk, x, y, z call write_real(x) @@ -209,7 +209,7 @@ program combine_paraview_data call write_real(dat(1,NGLLY,1,ispec)) mask_ibool(iglob4) = .true. endif - if(.not. mask_ibool(iglob5)) then + if (.not. mask_ibool(iglob5)) then numpoin = numpoin + 1 read(25,*) njunk, x, y, z call write_real(x) @@ -218,7 +218,7 @@ program combine_paraview_data call write_real(dat(1,1,NGLLZ,ispec)) mask_ibool(iglob5) = .true. endif - if(.not. mask_ibool(iglob6)) then + if (.not. mask_ibool(iglob6)) then numpoin = numpoin + 1 read(25,*) njunk, x, y, z call write_real(x) @@ -227,7 +227,7 @@ program combine_paraview_data call write_real(dat(NGLLX,1,NGLLZ,ispec)) mask_ibool(iglob6) = .true. endif - if(.not. mask_ibool(iglob7)) then + if (.not. mask_ibool(iglob7)) then numpoin = numpoin + 1 read(25,*) njunk, x, y, z call write_real(x) @@ -236,7 +236,7 @@ program combine_paraview_data call write_real(dat(NGLLX,NGLLY,NGLLZ,ispec)) mask_ibool(iglob7) = .true. endif - if(.not. mask_ibool(iglob8)) then + if (.not. mask_ibool(iglob8)) then numpoin = numpoin + 1 read(25,*) njunk, x, y, z call write_real(x) @@ -286,7 +286,7 @@ program combine_paraview_data do j = 1, NGLLY do i = 1, NGLLX iglob = ibool(i,j,k,ispec) - if(.not. mask_ibool(iglob)) then + if (.not. mask_ibool(iglob)) then numpoin = numpoin + 1 x = xstore(iglob) y = ystore(iglob) @@ -377,7 +377,7 @@ program combine_paraview_data do j = 1, NGLLY do i = 1, NGLLX iglob = ibool(i,j,k,ispec) - if(.not. mask_ibool(iglob)) then + if (.not. mask_ibool(iglob)) then numpoin = numpoin + 1 num_ibool(iglob) = numpoin mask_ibool(iglob) = .true. diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/measure_adj/ma_sub.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/measure_adj/ma_sub.f90 index 306b41968..c0295da5f 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/measure_adj/ma_sub.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/measure_adj/ma_sub.f90 @@ -180,7 +180,7 @@ subroutine mt_measure(datafile,filename,dat_dt,syn_dt,syn_dt_phydisp,t0,dt,npts, ! assemble omega vector (NPT is the FFT length) wvec(:) = 0. do j = 1,NPT - if(j > NPT/2+1) then + if (j > NPT/2+1) then wvec(j) = dw*(j-NPT-1) ! negative frequencies in second half else wvec(j) = dw*(j-1) ! positive frequencies in first half @@ -200,7 +200,7 @@ subroutine mt_measure(datafile,filename,dat_dt,syn_dt,syn_dt_phydisp,t0,dt,npts, ampmax_unw = 0. i_pmax_dat = 1 do i = 1, fnum ! loop over frequencies - if( abs(dat_dtwo(i)) > ampmax_unw) then + if ( abs(dat_dtwo(i)) > ampmax_unw) then ampmax_unw = abs(dat_dtwo(i)) i_pmax_dat = i endif @@ -209,7 +209,7 @@ subroutine mt_measure(datafile,filename,dat_dt,syn_dt,syn_dt_phydisp,t0,dt,npts, ampmax_unw = 0. i_amp_max_unw = 1 do i = 1, fnum - if( abs(syn_dtwo(i)) > ampmax_unw) then + if ( abs(syn_dtwo(i)) > ampmax_unw) then ampmax_unw = abs(syn_dtwo(i)) i_amp_max_unw = i endif @@ -223,11 +223,11 @@ subroutine mt_measure(datafile,filename,dat_dt,syn_dt,syn_dt_phydisp,t0,dt,npts, i_right = fnum i_right_stop = 0 do i = 1,fnum - if( abs(syn_dtwo(i)) <= abs(wtr_use_unw) .and. i_right_stop==0 .and. i > i_amp_max_unw ) then + if ( abs(syn_dtwo(i)) <= abs(wtr_use_unw) .and. i_right_stop==0 .and. i > i_amp_max_unw ) then i_right_stop = 1 ! power dips below water-level i_right = i endif - if( abs(syn_dtwo(i)) >= 10.*abs(wtr_use_unw) .and. i_right_stop==1 .and. i > i_amp_max_unw) then + if ( abs(syn_dtwo(i)) >= 10.*abs(wtr_use_unw) .and. i_right_stop==1 .and. i > i_amp_max_unw) then i_right_stop = 0 ! power goes above 10*water-level i_right = i endif @@ -295,7 +295,7 @@ subroutine mt_measure(datafile,filename,dat_dt,syn_dt,syn_dt_phydisp,t0,dt,npts, ampmax = 0. i_amp_max = 1 do i = 1, fnum - if( abs(syn_dtw_ho(i)) > ampmax) then + if ( abs(syn_dtw_ho(i)) > ampmax) then ampmax = abs(syn_dtw_ho(i)) i_amp_max = i endif @@ -338,7 +338,7 @@ subroutine mt_measure(datafile,filename,dat_dt,syn_dt,syn_dt_phydisp,t0,dt,npts, ! water level for multitaper measurements ampmax = 0. do i = 1, fnum - if( abs(bot_mtm(i)) > ampmax) then + if ( abs(bot_mtm(i)) > ampmax) then ampmax = abs(bot_mtm(i)) i_amp_max = i endif @@ -348,8 +348,8 @@ subroutine mt_measure(datafile,filename,dat_dt,syn_dt,syn_dt_phydisp,t0,dt,npts, ! calculate MT transfer function using water level do i = 1, fnum - if(abs(bot_mtm(i)) > abs(wtr_use)) trans_mtm(i) = top_mtm(i) / bot_mtm(i) - if(abs(bot_mtm(i)) < abs(wtr_use)) trans_mtm(i) = top_mtm(i) / (bot_mtm(i)+wtr_use) + if (abs(bot_mtm(i)) > abs(wtr_use)) trans_mtm(i) = top_mtm(i) / bot_mtm(i) + if (abs(bot_mtm(i)) < abs(wtr_use)) trans_mtm(i) = top_mtm(i) / (bot_mtm(i)+wtr_use) enddo ! multitaper phase, abs, tt, and amp (freq) @@ -390,7 +390,7 @@ subroutine mt_measure(datafile,filename,dat_dt,syn_dt,syn_dt_phydisp,t0,dt,npts, bot_mtm(:) = cmplx(0.,0.) do ictaper = 1, ntaper - if(ictaper==iom) cycle + if (ictaper==iom) cycle ! apply ictaper-th taper syn_dtw_h(1:nlen) = syn_dtw(1:nlen) * tas(1:nlen,ictaper) @@ -416,7 +416,7 @@ subroutine mt_measure(datafile,filename,dat_dt,syn_dt,syn_dt_phydisp,t0,dt,npts, ! water level ampmax = 0. do i = 1, fnum - if( abs(bot_mtm(i))>ampmax) then + if ( abs(bot_mtm(i))>ampmax) then ampmax = abs(bot_mtm(i)) i_amp_max = i endif @@ -425,8 +425,8 @@ subroutine mt_measure(datafile,filename,dat_dt,syn_dt,syn_dt_phydisp,t0,dt,npts, ! calculate transfer function using water level do i = 1, fnum - if(abs(bot_mtm(i))>abs(wtr_use)) trans_mtm(i) = top_mtm(i) / bot_mtm(i) - if(abs(bot_mtm(i))<=abs(wtr_use)) trans_mtm(i) = top_mtm(i) /(bot_mtm(i)+wtr_use) + if (abs(bot_mtm(i))>abs(wtr_use)) trans_mtm(i) = top_mtm(i) / bot_mtm(i) + if (abs(bot_mtm(i))<=abs(wtr_use)) trans_mtm(i) = top_mtm(i) /(bot_mtm(i)+wtr_use) enddo call write_trans(filename,trans_mtm,wvec,fnum,i_right,idf_new,df,tshift,dlnA, & @@ -595,13 +595,13 @@ subroutine mt_adj(istart,dat_dtw,syn_dtw,syn_dtw_phydisp,nlen,dt,tshift,dlnA,sig if (istart + nlen > NDIM) stop 'Check istart + nlen and NPT' ! waveform - if(imeas==1 .or. imeas==2) then + if (imeas==1 .or. imeas==2) then print *, ' computing waveform adjoint source' - else if(imeas==3 .or. imeas==4) then + else if (imeas==3 .or. imeas==4) then print *, ' computing banana-doughtnut adjoint source' - else if(imeas==5 .or. imeas==6) then + else if (imeas==5 .or. imeas==6) then print *, ' computing cross-correlation adjoint source' - else if(imeas==7 .or. imeas==8) then + else if (imeas==7 .or. imeas==8) then print *, ' computing multitaper adjoint source' endif @@ -624,7 +624,7 @@ subroutine mt_adj(istart,dat_dtw,syn_dtw,syn_dtw_phydisp,nlen,dt,tshift,dlnA,sig ! ---------------------------------- ! CROSS CORRELATION ADJOINT SOURCES LQY: does time_window needs to be applied here? ! ---------------------------------- - if( (imeas >= 3).and.(imeas <= 6) ) then + if ( (imeas >= 3).and.(imeas <= 6) ) then ! compute synthetic velocity if (USE_PHYSICAL_DISPERSION) then @@ -663,7 +663,7 @@ subroutine mt_adj(istart,dat_dtw,syn_dtw,syn_dtw_phydisp,nlen,dt,tshift,dlnA,sig ! ---------------------------------------------- ! FREQUENCY-DOMAIN TAPERS FOR MT ADJOINT SOURCES ! ---------------------------------------------- - if( is_mtm == 1 ) then + if ( is_mtm == 1 ) then ! initialize water levels for err_dtau/dlnA division dtau_wtr = WTR * sum(abs(dtau_w(i_left:i_right)))/(i_right-i_left) ! CHT i_left @@ -780,7 +780,7 @@ subroutine mt_adj(istart,dat_dtw,syn_dtw,syn_dtw_phydisp,nlen,dt,tshift,dlnA,sig ! compute P_j(w) and Q_j(w) ! NOTE: the MT measurement is incorporated here ! also note that wp_taper and wq_taper can contain uncertainty estimations - if( DO_RAY_DENSITY_SOURCE ) then + if ( DO_RAY_DENSITY_SOURCE ) then ! uses a misfit measurement dtau, dlnA = 1 pwc_adj(:) = pwc_adj(:) * cmplx(1.0,0.) * cmplx(wp_taper(:),0.) qwc_adj(:) = qwc_adj(:) * cmplx(1.0,0.) * cmplx(wq_taper(:),0.) @@ -826,42 +826,42 @@ subroutine mt_adj(istart,dat_dtw,syn_dtw,syn_dtw_phydisp,nlen,dt,tshift,dlnA,sig i1 = istart + i -1 ! start index in the full adjoint source array(1:npts) ! waveform - if(imeas==1 .or. imeas==2) then + if (imeas==1 .or. imeas==2) then tr_adj_src(i1) = -dat_dtw(i)/waveform_d2 * time_window(i) ! imeas=1 ! consider normalizing this by waveform_d2 am_adj_src(i1) = ( syn_dtw(i) - dat_dtw(i) ) * time_window(i) ! imeas=2 ! use pure data waveform in time window - if( NO_WAVEFORM_DIFFERENCE ) then + if ( NO_WAVEFORM_DIFFERENCE ) then tr_adj_src(i1) = dat_dtw(i) * time_window(i) ! waveform misfit (imeas=1) endif ! banana-doughnut kernel adjoint source (no measurement) - else if(imeas==3 .or. imeas==4) then + else if (imeas==3 .or. imeas==4) then tr_adj_src(i1) = ft_bar_t(i) * time_window(i) ! imeas=3 am_adj_src(i1) = fa_bar_t(i) * time_window(i) ! imreas=4 ! cross-correlation - else if(imeas==5 .or. imeas==6) then + else if (imeas==5 .or. imeas==6) then tr_adj_src(i1) = -(tshift / sigma_dt_cc**2 ) * ft_bar_t(i) * time_window(i) am_adj_src(i1) = -(dlnA / sigma_dlnA_cc**2 ) * fa_bar_t(i) * time_window(i) ! ray density - if( DO_RAY_DENSITY_SOURCE ) then + if ( DO_RAY_DENSITY_SOURCE ) then ! uses a misfit measurement of 1 tr_adj_src(i1) = - (1.0) * ft_bar_t(i) * time_window(i) am_adj_src(i1) = - (1.0) * fa_bar_t(i) * time_window(i) endif ! multitaper - else if(imeas==7 .or. imeas==8) then + else if (imeas==7 .or. imeas==8) then tr_adj_src(i1) = fp(i) * time_window(i) am_adj_src(i1) = fq(i) * time_window(i) endif enddo ! ------------------------------------- - ! COMPUTE MISFIT FUNCTION VALUE + ! COMPUTE MISFIT function VALUE ! ------------------------------------- ! CHT: compute misfit function value and measurement value @@ -873,34 +873,34 @@ subroutine mt_adj(istart,dat_dtw,syn_dtw,syn_dtw_phydisp,nlen,dt,tshift,dlnA,sig !window_chi(:) = 0. ! misfit function value - if(is_mtm==1) window_chi(1) = 0.5 * 2.0 * df * sum( (dtau_w(1:i_right))**2 * wp_taper(1:i_right) ) - if(is_mtm==1) window_chi(2) = 0.5 * 2.0 * df * sum( (dlnA_w(1:i_right))**2 * wq_taper(1:i_right) ) + if (is_mtm==1) window_chi(1) = 0.5 * 2.0 * df * sum( (dtau_w(1:i_right))**2 * wp_taper(1:i_right) ) + if (is_mtm==1) window_chi(2) = 0.5 * 2.0 * df * sum( (dlnA_w(1:i_right))**2 * wq_taper(1:i_right) ) window_chi(3) = 0.5 * (tshift/sigma_dt_cc)**2 window_chi(4) = 0.5 * (dlnA/sigma_dlnA_cc)**2 ! cc/averaged mt measurement (no uncertainty estimates) - if(is_mtm==1) window_chi(5) = sum( dtau_w(1:i_right) * w_taper(1:i_right) ) / sum(w_taper(1:i_right) ) - if(is_mtm==1) window_chi(6) = sum( dlnA_w(1:i_right) * w_taper(1:i_right) ) / sum(w_taper(1:i_right) ) + if (is_mtm==1) window_chi(5) = sum( dtau_w(1:i_right) * w_taper(1:i_right) ) / sum(w_taper(1:i_right) ) + if (is_mtm==1) window_chi(6) = sum( dlnA_w(1:i_right) * w_taper(1:i_right) ) / sum(w_taper(1:i_right) ) window_chi(7) = tshift window_chi(8) = dlnA ! replaces misfit function values - if( DO_RAY_DENSITY_SOURCE ) then + if ( DO_RAY_DENSITY_SOURCE ) then ! uses misfit measurements equal to 1 - if(is_mtm==1) window_chi(1) = 0.5 * 2.0 * df * sum( (1.0)**2 * wp_taper(1:i_right) ) - if(is_mtm==1) window_chi(2) = 0.5 * 2.0 * df * sum( (1.0)**2 * wq_taper(1:i_right) ) + if (is_mtm==1) window_chi(1) = 0.5 * 2.0 * df * sum( (1.0)**2 * wp_taper(1:i_right) ) + if (is_mtm==1) window_chi(2) = 0.5 * 2.0 * df * sum( (1.0)**2 * wq_taper(1:i_right) ) window_chi(3) = 0.5 * (1.0)**2 window_chi(4) = 0.5 * (1.0)**2 - if(is_mtm==1) window_chi(5) = sum( 1.0 * w_taper(1:i_right) ) / sum(w_taper(1:i_right) ) - if(is_mtm==1) window_chi(6) = sum( 1.0 * w_taper(1:i_right) ) / sum(w_taper(1:i_right) ) + if (is_mtm==1) window_chi(5) = sum( 1.0 * w_taper(1:i_right) ) / sum(w_taper(1:i_right) ) + if (is_mtm==1) window_chi(6) = sum( 1.0 * w_taper(1:i_right) ) / sum(w_taper(1:i_right) ) window_chi(7) = 1.0 window_chi(8) = 1.0 endif ! estimated measurement uncertainties - if(is_mtm==1) window_chi(9) = sigma_dt - if(is_mtm==1) window_chi(10) = sigma_dlnA + if (is_mtm==1) window_chi(9) = sigma_dt + if (is_mtm==1) window_chi(10) = sigma_dlnA window_chi(11) = sigma_dt_cc window_chi(12) = sigma_dlnA_cc @@ -910,15 +910,15 @@ subroutine mt_adj(istart,dat_dtw,syn_dtw,syn_dtw_phydisp,nlen,dt,tshift,dlnA,sig window_chi(15) = 0.5 * waveform_chi window_chi(16) = nlen*dt - if(imeas <= 2) then ! waveform + if (imeas <= 2) then ! waveform tr_chi = 0.5 * waveform_chi am_chi = 0.5 * waveform_chi - else if( (imeas >= 3).and.(imeas <= 6) ) then ! cross_correlation + else if ( (imeas >= 3).and.(imeas <= 6) ) then ! cross_correlation tr_chi = window_chi(3) am_chi = window_chi(4) - else if( (imeas==7).or.(imeas==8) ) then ! multitaper + else if ( (imeas==7).or.(imeas==8) ) then ! multitaper tr_chi = window_chi(1) am_chi = window_chi(2) @@ -1058,7 +1058,7 @@ subroutine cc_measure_select(tshift,dlnA,cc_max) implicit none double precision, intent(inout) :: tshift, dlnA, cc_max - if( (cc_max < CC_MIN) .or. (tshift < TSHIFT_MIN) .or. (tshift > TSHIFT_MAX) & + if ( (cc_max < CC_MIN) .or. (tshift < TSHIFT_MIN) .or. (tshift > TSHIFT_MAX) & .or. (dlnA < DLNA_MIN) .or. (dlnA > DLNA_MAX) ) then ! zero the CC measurments if (DISPLAY_DETAILS) then @@ -1104,7 +1104,7 @@ subroutine mt_measure_select(nlen,tshift,i_pmax_syn,dtau_w,err_dt, & T_pmax = 1./ f_pmax Wlen = dt*nlen - if( NCYCLE_IN_WINDOW * T_pmax > Wlen ) then + if ( NCYCLE_IN_WINDOW * T_pmax > Wlen ) then print *, ' MTM: rejecting for too few cycles within time window:' print *, ' T_pmax : ', sngl(T_pmax) print *, ' Wlen : ', sngl(Wlen) @@ -1126,9 +1126,9 @@ subroutine mt_measure_select(nlen,tshift,i_pmax_syn,dtau_w,err_dt, & ! number of tapers (slepian tapers, type = 1) ntaper = int(NPI * 2.0) - if( ntaper > 10 ) ntaper = 10 - if( ntaper < 1 ) ntaper = 10 - if( use_trace .and. fstart >= fend - ntaper*df ) then + if ( ntaper > 10 ) ntaper = 10 + if ( ntaper < 1 ) ntaper = 10 + if ( use_trace .and. fstart >= fend - ntaper*df ) then print *, ' MTM: rejecting for frequency range (NCYCLE_IN_WINDOW/Wlen):' print *, ' fstart, fend, df, ntaper : ', sngl(fstart),sngl(fend),sngl(df),ntaper print *, ' NCYCLE_IN_WINDOW, Wlen : ', NCYCLE_IN_WINDOW,sngl(Wlen), & @@ -1141,7 +1141,7 @@ subroutine mt_measure_select(nlen,tshift,i_pmax_syn,dtau_w,err_dt, & ! assemble frequency vector (NPT is the FFT length) fvec(:) = 0. do j = 1,NPT - if(j > NPT/2+1) then + if (j > NPT/2+1) then fvec(j) = df*(j-NPT-1) ! negative frequencies in second half else fvec(j) = df*(j-1) ! positive frequencies in first half @@ -1253,7 +1253,7 @@ subroutine interpolate_dat_and_syn(data, syn, syn_phydisp, tstart, tend, t0, dt, !print *, '*** diff tstart = ', t0+(istart-1)*dt - tstart ! limits array bounds - if( nlen > NPT ) nlen = NPT + if ( nlen > NPT ) nlen = NPT ! move checking inside subroutine if (nlen <= 1) stop 'Check the length of the data and syn arrays' @@ -1263,7 +1263,7 @@ subroutine interpolate_dat_and_syn(data, syn, syn_phydisp, tstart, tend, t0, dt, ii = floor((time-t0)/dt) + 1 ! checks out-of-bounds (very unlikely event!) - if( ii >= NPT ) cycle + if ( ii >= NPT ) cycle t1 = floor((time-t0)/dt) * dt + t0 @@ -1304,12 +1304,12 @@ subroutine compute_cc(syn, data, nlen, dt, ishift, tshift, dlnA, cc_max) !!$ !!$ cc = 0. !!$ do j = 1, nlen -!!$ if((j+i) > 1 .and. (j+i) < nlen) cc = cc + syn(j) * data(j+i) +!!$ if ((j+i) > 1 .and. (j+i) < nlen) cc = cc + syn(j) * data(j+i) !!$ enddo !!$ -!!$ !if(cc > cc_max) then +!!$ !if (cc > cc_max) then !!$ ! CHT, 07-Sept-2008: Do not allow time shifts larger than the specified input -!!$ if(cc > cc_max .and. abs(i*dt) <= BEFORE_TSHIFT ) then +!!$ if (cc > cc_max .and. abs(i*dt) <= BEFORE_TSHIFT ) then !!$ cc_max = cc !!$ ishift = i !!$ endif @@ -1350,7 +1350,7 @@ subroutine compute_cc(syn, data, nlen, dt, ishift, tshift, dlnA, cc_max) ! cc as a function of i cc = 0. do j = i1, i2 ! loop over full window length - if((j+i)>=1 .and. (j+i)<=nlen) cc = cc + syn(j)*data(j+i) ! d is shifted by i + if ((j+i)>=1 .and. (j+i)<=nlen) cc = cc + syn(j)*data(j+i) ! d is shifted by i enddo cc = cc/norm @@ -1358,7 +1358,7 @@ subroutine compute_cc(syn, data, nlen, dt, ishift, tshift, dlnA, cc_max) ! CHT: do not allow time shifts larger than the specified input range ! This is an important criterion, since it may pick TSHIFT_MIN or TSHIFT_MAX ! if cc_max within the interval occurs on the boundary. - if( (i*dt >= TSHIFT_MIN).and.(i*dt <= TSHIFT_MAX) ) then + if ( (i*dt >= TSHIFT_MIN).and.(i*dt <= TSHIFT_MAX) ) then cc_max = cc ishift = i endif @@ -1428,8 +1428,8 @@ subroutine compute_average_error(data_dtw,syn_dtw_cc,syn_dtw_cc_dt,nlen,dt,sigma else ! make sure that the uncertainty estimates are not below the water level; ! otherwise, the adjoint sources will blow up unreasonably - if( sigma_dt < DT_SIGMA_MIN) sigma_dt = DT_SIGMA_MIN - if( sigma_dlnA < DLNA_SIGMA_MIN) sigma_dlnA = DLNA_SIGMA_MIN + if ( sigma_dt < DT_SIGMA_MIN) sigma_dt = DT_SIGMA_MIN + if ( sigma_dlnA < DLNA_SIGMA_MIN) sigma_dlnA = DLNA_SIGMA_MIN endif @@ -1532,14 +1532,14 @@ subroutine write_trans(filename, trans, wvec, fnum, i_right, idf_new, df, tshift smth = phi_wt(i+1) + phi_wt(i-1) - 2.0 * phi_wt(i) smth1 = (phi_wt(i+1) + TWOPI) + phi_wt(i-1) - 2.0 * phi_wt(i) smth2 = (phi_wt(i+1) - TWOPI) + phi_wt(i-1) - 2.0 * phi_wt(i) - if(abs(smth1) PHASE_STEP)then + if (abs(smth1) PHASE_STEP) then if (DISPLAY_DETAILS .and. ioactive) & print *, ' phase correction : 2 pi', sngl(fr(i)), sngl(phi_wt(i) - phi_wt(i+1)) do j = i+1, i_right phi_wt(j) = phi_wt(j) + TWOPI enddo endif - if(abs(smth2) PHASE_STEP)then + if (abs(smth2) PHASE_STEP) then if (DISPLAY_DETAILS .and. ioactive) & print *, ' phase correction : - 2 pi', sngl(fr(i)), sngl(phi_wt(i) - phi_wt(i+1)) do j = i+1, i_right @@ -1553,7 +1553,7 @@ subroutine write_trans(filename, trans, wvec, fnum, i_right, idf_new, df, tshift dlnA_wt(i) = log(abs_wt(i)) + dlnA !!dlnA_wt(i) = abs_wt(i) - 1. + dlnA - if(mod(i,idf_new)==0 .and. OUTPUT_MEASUREMENT_FILES .and. ioactive) then + if (mod(i,idf_new)==0 .and. OUTPUT_MEASUREMENT_FILES .and. ioactive) then write(30,*) fr(i), dlnA_wt(i) write(40,*) fr(i), phi_wt(i) write(50,*) fr(i), dtau_wt(i) @@ -1806,7 +1806,7 @@ subroutine taper_start(syn,npt,itmax) Wt = TWOPI / (2.0*(itmax-1)) ! period of the taper - if(DISPLAY_DETAILS) print *, 'tapering start of adjoint source from index 1 to index ', itmax + if (DISPLAY_DETAILS) print *, 'tapering start of adjoint source from index 1 to index ', itmax ! apply a cosine taper from the start to the max value, ! such that the starting point is exactly zero @@ -1938,7 +1938,7 @@ subroutine read_par_file(fstart0,fend0,tt,dtt,nn,chan) !passes = 2 ! ray density - if( DO_RAY_DENSITY_SOURCE ) ERROR_TYPE = 0 + if ( DO_RAY_DENSITY_SOURCE ) ERROR_TYPE = 0 ! assign additional parameters and stop for certain inconsistencies if (fstart0 >= fend0) & @@ -2001,54 +2001,54 @@ subroutine get_sacfile_header(data_file,yr,jda,ho,mi,sec,ntw,sta, & ! string headers call getkhv('knetwk',ntw,nerr) - if(nerr /= 0) then + if (nerr /= 0) then write(*,*)'Error reading variable: knetwk' call exit(-1) endif call getkhv('kstnm',sta,nerr) - if(nerr /= 0) then + if (nerr /= 0) then write(*,*)'Error reading variable: kstnm' call exit(-1) endif call getkhv('kcmpnm',comp,nerr) - if(nerr /= 0) then + if (nerr /= 0) then write(*,*)'Error reading variable: kcmpnm' call exit(-1) endif ! decimal headers call getfhv('dist',tmp,nerr) - if(nerr /= 0) then + if (nerr /= 0) then write(*,*)'Error reading variable: dist' call exit(-1) endif dist = tmp call getfhv('az',tmp,nerr) - if(nerr /= 0) then + if (nerr /= 0) then write(*,*)'Error reading variable: az' call exit(-1) endif az = tmp call getfhv('baz',tmp,nerr) - if(nerr /= 0) then + if (nerr /= 0) then write(*,*)'Error reading variable: baz' call exit(-1) endif baz = tmp call getfhv('stlo',tmp,nerr) - if(nerr /= 0) then + if (nerr /= 0) then write(*,*)'Error reading variable: stlo' call exit(-1) endif slon = tmp call getfhv('stla',tmp,nerr) - if(nerr /= 0) then + if (nerr /= 0) then write(*,*)'Error reading variable: stla' call exit(-1) endif @@ -2189,15 +2189,15 @@ subroutine setup_weighting(chan_syn) tend = min(tend, t0+(npts-1)*dt) ! body wave picks - if( tend <= T_surfacewaves ) then - if( cmp(1:1) == "Z" ) num_P_SV_V = num_P_SV_V + 1.d0 - if( cmp(1:1) == "R" ) num_P_SV_R = num_P_SV_R + 1.d0 - if( cmp(1:1) == "T" ) num_SH_T = num_SH_T + 1.d0 + if ( tend <= T_surfacewaves ) then + if ( cmp(1:1) == "Z" ) num_P_SV_V = num_P_SV_V + 1.d0 + if ( cmp(1:1) == "R" ) num_P_SV_R = num_P_SV_R + 1.d0 + if ( cmp(1:1) == "T" ) num_SH_T = num_SH_T + 1.d0 else ! surface wave picks - if( cmp(1:1) == "Z" ) num_Rayleigh_V = num_Rayleigh_V + 1.d0 - if( cmp(1:1) == "R" ) num_Rayleigh_R = num_Rayleigh_R + 1.d0 - if( cmp(1:1) == "T" ) num_Love_T = num_Love_T + 1.d0 + if ( cmp(1:1) == "Z" ) num_Rayleigh_V = num_Rayleigh_V + 1.d0 + if ( cmp(1:1) == "R" ) num_Rayleigh_R = num_Rayleigh_R + 1.d0 + if ( cmp(1:1) == "T" ) num_Love_T = num_Love_T + 1.d0 endif enddo @@ -2206,20 +2206,20 @@ subroutine setup_weighting(chan_syn) ! (also cross-check comp name in filename) ! transverse iposition = INDEX( trim(synfile), comp_T, .false. ) - if( iposition > 3 .and. iposition < len_trim( synfile) ) then - if( cmp(1:1) /= "T" ) stop 'error T component pick' + if ( iposition > 3 .and. iposition < len_trim( synfile) ) then + if ( cmp(1:1) /= "T" ) stop 'error T component pick' picks_T = picks_T + npicks else ! radial iposition = INDEX( trim(synfile), comp_R, .false. ) - if( iposition > 3 .and. iposition < len_trim( synfile) ) then - if( cmp(1:1) /= "R" ) stop 'error R component pick' + if ( iposition > 3 .and. iposition < len_trim( synfile) ) then + if ( cmp(1:1) /= "R" ) stop 'error R component pick' picks_R = picks_R + npicks else ! vertical iposition = INDEX( trim(synfile), comp_Z, .false. ) - if( iposition > 3 .and. iposition < len_trim( synfile) ) then - if( cmp(1:1) /= "Z" ) stop 'error Z component pick' + if ( iposition > 3 .and. iposition < len_trim( synfile) ) then + if ( cmp(1:1) /= "Z" ) stop 'error Z component pick' picks_Z = picks_Z + npicks endif endif @@ -2230,11 +2230,11 @@ subroutine setup_weighting(chan_syn) ! check with total number of picks per component - if( nint( num_P_SV_R + num_Rayleigh_R ) /= picks_R ) stop 'error R picks' - if( nint( num_P_SV_V + num_Rayleigh_V ) /= picks_Z ) stop 'error Z picks' - if( nint( num_SH_T + num_Love_T ) /= picks_T ) stop 'error T picks' + if ( nint( num_P_SV_R + num_Rayleigh_R ) /= picks_R ) stop 'error R picks' + if ( nint( num_P_SV_V + num_Rayleigh_V ) /= picks_Z ) stop 'error Z picks' + if ( nint( num_SH_T + num_Love_T ) /= picks_T ) stop 'error T picks' - if( DISPLAY_DETAILS ) then + if ( DISPLAY_DETAILS ) then print * print *,'weighting measurements: ' print *,' picks T:',picks_T @@ -2257,22 +2257,22 @@ subroutine setup_weighting(chan_syn) weight_Z = 1.0d0 ! weighting tries to balance love waves (tranverse) versus rayleigh waves (radial + vertical) - !if( picks_T > 0 ) then - ! if( picks_R + picks_Z > 0 ) weight_T = dble(picks_R + picks_Z)/dble(picks_T) + !if ( picks_T > 0 ) then + ! if ( picks_R + picks_Z > 0 ) weight_T = dble(picks_R + picks_Z)/dble(picks_T) !endif ! use normalization as weights - if( picks_T > 0 ) weight_T = 1.d0 / picks_T - if( picks_R > 0 ) weight_R = 1.d0 / picks_R - if( picks_Z > 0 ) weight_Z = 1.d0 / picks_Z + if ( picks_T > 0 ) weight_T = 1.d0 / picks_T + if ( picks_R > 0 ) weight_R = 1.d0 / picks_R + if ( picks_Z > 0 ) weight_Z = 1.d0 / picks_Z ! use normalization (no traces means zero weights) - if( num_P_SV_R > 0. ) num_P_SV_R = 1.d0 / num_P_SV_R - if( num_P_SV_V > 0. ) num_P_SV_V = 1.d0 / num_P_SV_V - if( num_SH_T > 0. ) num_SH_T = 1.d0 / num_SH_T - if( num_Rayleigh_R > 0. ) num_Rayleigh_R = 1.d0 / num_Rayleigh_R - if( num_Rayleigh_V > 0. ) num_Rayleigh_V = 1.d0 / num_Rayleigh_V - if( num_Love_T > 0. ) num_Love_T = 1.d0 / num_Love_T + if ( num_P_SV_R > 0. ) num_P_SV_R = 1.d0 / num_P_SV_R + if ( num_P_SV_V > 0. ) num_P_SV_V = 1.d0 / num_P_SV_V + if ( num_SH_T > 0. ) num_SH_T = 1.d0 / num_SH_T + if ( num_Rayleigh_R > 0. ) num_Rayleigh_R = 1.d0 / num_Rayleigh_R + if ( num_Rayleigh_V > 0. ) num_Rayleigh_V = 1.d0 / num_Rayleigh_V + if ( num_Love_T > 0. ) num_Love_T = 1.d0 / num_Love_T print *,' weight of P_SV_R:',num_P_SV_R print *,' weight of P_SV_V:',num_P_SV_V diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/measure_adj/ma_sub2.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/measure_adj/ma_sub2.f90 index f51bb18d7..5db50a9ca 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/measure_adj/ma_sub2.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/measure_adj/ma_sub2.f90 @@ -28,7 +28,7 @@ subroutine fft(n,xi,zzign,dt) integer :: l,iblock,nblock,i,lbhalf,j,lx ! sign must be +1. or -1. - if(zzign >= 0.) then + if (zzign >= 0.) then zign = 1. else zign = -1. @@ -37,7 +37,7 @@ subroutine fft(n,xi,zzign,dt) lx = 2**n ! checks bounds - if( lx > NPT ) stop 'error fft increase NPT, or decrease n' + if ( lx > NPT ) stop 'error fft increase NPT, or decrease n' @@ -61,7 +61,7 @@ subroutine fft(n,xi,zzign,dt) j = istart+i jh = j+lbhalf ! checks bounds - if( jh < 1 .or. jh > NPT ) stop 'error fft bounds' + if ( jh < 1 .or. jh > NPT ) stop 'error fft bounds' q = xi(jh)*wk xi(jh) = xi(j)-q @@ -70,25 +70,25 @@ subroutine fft(n,xi,zzign,dt) do 3 i=2,n ii = i - if(k < m(i)) go to 4 + if (k < m(i)) goto 4 3 k = k-m(i) 4 k = k+m(ii) k = 0 do 7 j=1,lx - if(k < j) go to 5 + if (k < j) goto 5 hold = xi(j) ! checks bounds - if( k+1 < 1 .or. k+1 > NPT ) stop 'error fft k bounds' + if ( k+1 < 1 .or. k+1 > NPT ) stop 'error fft k bounds' xi(j) = xi(k+1) xi(k+1) = hold 5 do 6 i=1,n ii = i - if(k < m(i)) go to 7 + if (k < m(i)) goto 7 6 k = k-m(i) 7 k = k+m(ii) ! final steps deal with dt factors - if(zign > 0.) then ! FORWARD FFT + if (zign > 0.) then ! FORWARD FFT do i = 1,lx xi(i) = xi(i)*dt ! multiplication by dt enddo @@ -189,7 +189,7 @@ subroutine staper(nt, fw, nev, v, ndim, a, w) r2 = sqrt(2.) - if(nt < 2) return + if (nt < 2) return nxi=mod(nt,2) lh=(nt/2)+nxi lp1=nt+1 @@ -199,7 +199,7 @@ subroutine staper(nt, fw, nev, v, ndim, a, w) do 10 i=1,lh a(i)=com*(i-hn)**2 10 w(i)=0.5*dble(i*(nt-i)) - if(nxi == 0) then + if (nxi == 0) then asav=a(lh)-w(lh) a(lh)=a(lh)+w(lh) rbd=1./(a(lh)+w(lh-1)) @@ -218,12 +218,12 @@ subroutine staper(nt, fw, nev, v, ndim, a, w) call tsturm(nt,lh,a,a(lh+1),w,neven,v,ndim,w(lh+1),0) do 20 i=1,neven k=2*i-1 - if(nxi == 1) v(lh,k)=r2*v(lh,k) + if (nxi == 1) v(lh,k)=r2*v(lh,k) do 20 j=1,lh 20 v(lp1-j,k)=v(j,k) - if(nodd <= 0) goto 34 + if (nodd <= 0) goto 34 ! Do the odd tapers - if(nxi == 0) then + if (nxi == 0) then a(lh)=asav*rbd else a(nt)=asav*rbd @@ -232,7 +232,7 @@ subroutine staper(nt, fw, nev, v, ndim, a, w) call tsturm(nt,lh-nxi,a,a(lh+1),w,nodd,v,ndim,w(lh+1),1) do 30 i=1,nodd k=2*i - if(nxi == 1) v(lh,k)=0. + if (nxi == 1) v(lh,k)=0. do 30 j=1,lh 30 v(lp1-j,k)=-v(j,k) 34 ntot=neven+nodd @@ -251,7 +251,7 @@ subroutine staper(nt, fw, nev, v, ndim, a, w) vmax=abs(v(1,m)) kmax=1 do 40 kk=2,lh - if(abs(v(kk,m)) <= vmax) goto 40 + if (abs(v(kk,m)) <= vmax) goto 40 kmax=kk vmax=abs(v(kk,m)) 40 continue @@ -293,35 +293,35 @@ subroutine tsturm(nt,n,a,b,w,nev,r,ndim,ev,ipar) !------------------------- - if(n <= 0.or.nev <= 0) return + if (n <= 0.or.nev <= 0) return umeps=1.-epsi do 5 i=1,nev 5 ev(i)=-1. u=1. do 1000 ik=1,nev - if(ik > 1) u=ev(ik-1)*umeps + if (ik > 1) u=ev(ik-1)*umeps el=min(ev(ik),u) 10 elam=0.5*(u+el) - if(abs(u-el) <= epsi1) goto 35 + if (abs(u-el) <= epsi1) goto 35 iag=0 q=a(1)-elam - if(q >= 0.) iag=iag+1 + if (q >= 0.) iag=iag+1 do 15 i=2,n - if(q == 0.) x=abs(b(i-1))/epsi - if(q /= 0.) x=w(i-1)/q + if (q == 0.) x=abs(b(i-1))/epsi + if (q /= 0.) x=w(i-1)/q q=a(i)-elam-x - if(q >= 0.) iag=iag+1 - if(iag > nev) goto 20 + if (q >= 0.) iag=iag+1 + if (iag > nev) goto 20 15 continue - if(iag >= ik) go to 20 + if (iag >= ik) goto 20 u=elam - go to 10 - 20 if(iag == ik) go to 30 + goto 10 + 20 if (iag == ik) goto 30 m=ik+1 do 25 i=m,iag 25 ev(i)=elam el=elam - go to 10 + goto 10 30 el=elam call root(u,el,elam,a,b,w,n,ik) 35 ev(ik)=elam @@ -361,30 +361,30 @@ subroutine root(u,el,elam,a,bb,w,n,ik) !---------------------- 5 elam=0.5*(u+el) - 10 if(abs(u-el) <= 1.5*epsi1) return + 10 if (abs(u-el) <= 1.5*epsi1) return an=a(1)-elam b=0. bn=-1./an iag=0 - if(an >= 0.) iag=iag+1 + if (an >= 0.) iag=iag+1 do 20 i=2,n - if(an == 0.) x=abs(bb(i-1))/epsi - if(an /= 0.) x=w(i-1)/an + if (an == 0.) x=abs(bb(i-1))/epsi + if (an /= 0.) x=w(i-1)/an an=a(i)-elam-x - if(an == 0.) an=epsi + if (an == 0.) an=epsi bm=b b=bn bn=((a(i)-elam)*b-bm*x-1.)/an - if(an >= 0.) iag=iag+1 + if (an >= 0.) iag=iag+1 20 continue - if(iag == ik) goto 25 + if (iag == ik) goto 25 u=elam goto 30 25 el=elam 30 del=1./bn - if(abs(del) <= epsi1) del=sign(epsi1,del) + if (abs(del) <= epsi1) del=sign(epsi1,del) elam=elam-del - if(elam >= u.or.elam <= el) goto 5 + if (elam >= u.or.elam <= el) goto 5 goto 10 end subroutine root @@ -457,9 +457,9 @@ end subroutine root !!$! do i = n_left, n_right !!$! cc = 0 !!$! do j = 1, npts -!!$! if((j+i)>1.and.(j+i)1.and.(j+i) cc_max) then +!!$! if ( cc > cc_max) then !!$! cc_max = cc !!$! ishift = i !!$! endif @@ -470,7 +470,7 @@ end subroutine root !!$! write(*,*)'shift synth seismogram by ', tshift, 'seconds' !!$ do i = 1, npts_win !!$ s_cor(i) = 0 -!!$ if( (i1-1+i-ishift) > 1 .and. (i1-1+i-ishift) 1 .and. (i1-1+i-ishift) =1 .and. (j+i)<=npts) cc = cc + s(j)*d(j+i) +!!$ if ((j+i)>=1 .and. (j+i)<=npts) cc = cc + s(j)*d(j+i) !!$ enddo !!$ if (cc > cc_max) then !!$ cc_max=cc diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/measure_adj/measure_adj.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/measure_adj/measure_adj.f90 index 4f35403a0..04ee16bde 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/measure_adj/measure_adj.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/measure_adj/measure_adj.f90 @@ -62,7 +62,7 @@ program measure_adj ! uses weights to balance love and rayleigh measurements ! we do a normalization of P_SV, P_SH, Love, Rayleigh with the number of measurement picks - if( DO_WEIGHTING ) call setup_weighting(chan) + if ( DO_WEIGHTING ) call setup_weighting(chan) ! input file: MEASUREMENT.WINDOWS open(11,file='MEASUREMENT.WINDOWS',status='old',iostat=ios) @@ -133,7 +133,7 @@ program measure_adj ! Access to the kidate, xapiir, and getfil is not simple and not ! supported under the current state of the SAC code base. - if(RUN_BANDPASS) then + if (RUN_BANDPASS) then call bandpass(data,npts,dt,fstart0,fend0) call bandpass(syn,npts,dt,fstart0,fend0) if (USE_PHYSICAL_DISPERSION) then @@ -229,7 +229,7 @@ program measure_adj print *, ' period of max data/syn power :', sngl(T_pmax_dat), sngl(T_pmax_syn) ! if MT measurement window is rejected by mt_measure_select, then use a CC measurement - if(.not. use_trace) then + if (.not. use_trace) then !stop 'Check why this MT measurement was rejected' print *, ' reverting from MT measurement to CC measurement...' imeas = imeas0 - 2 @@ -262,7 +262,7 @@ program measure_adj ! LQY: what is this section intended to do? ! reset imeas == 3 for adjoint sources without time shift and uncertainty scaling ! (pure cross-correlation adjoint source for banana-doughnuts) - if(imeas == 5 .and. trim(datafile) == trim(synfile) ) then + if (imeas == 5 .and. trim(datafile) == trim(synfile) ) then print *,'cross-correlation measurement:' print *,' only synthetic file: ',trim(synfile) print *,' without traveltime difference/uncertainty' @@ -289,18 +289,18 @@ program measure_adj print *, ' tr_chi = ', sngl(tr_chi), ' am_chi = ', sngl(am_chi) ! uses weighting to balance love / rayleigh measurements - if( DO_WEIGHTING ) then + if ( DO_WEIGHTING ) then ipick_type = 0 - if( tend <= T_surfacewaves ) then + if ( tend <= T_surfacewaves ) then ! body wave picks - if( cmp(1:1) == "Z" ) ipick_type = P_SV_V - if( cmp(1:1) == "R" ) ipick_type = P_SV_R - if( cmp(1:1) == "T" ) ipick_type = SH_T + if ( cmp(1:1) == "Z" ) ipick_type = P_SV_V + if ( cmp(1:1) == "R" ) ipick_type = P_SV_R + if ( cmp(1:1) == "T" ) ipick_type = SH_T else ! surface wave picks - if( cmp(1:1) == "Z" ) ipick_type = Rayleigh_V - if( cmp(1:1) == "R" ) ipick_type = Rayleigh_R - if( cmp(1:1) == "T" ) ipick_type = Love_T + if ( cmp(1:1) == "Z" ) ipick_type = Rayleigh_V + if ( cmp(1:1) == "R" ) ipick_type = Rayleigh_R + if ( cmp(1:1) == "T" ) ipick_type = Love_T endif ! LQY: shouldn't chi values be changed accordingly????? @@ -408,7 +408,7 @@ program measure_adj ! output the adjoint source (or ray density) as ASCII or SAC format print *, 'writing adjoint source to file for the full seismogram' - if( DO_RAY_DENSITY_SOURCE ) then + if ( DO_RAY_DENSITY_SOURCE ) then call dwascii(trim(adj_file_prefix)//'.density.adj',adj_syn_all,nn,tt,dtt) else call dwascii(trim(adj_file_prefix)//'.adj',adj_syn_all,nn,tt,dtt) diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/mtadj/mtadj_sub.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/mtadj/mtadj_sub.f90 index 8b4b771e4..003f0424f 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/mtadj/mtadj_sub.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/mtadj/mtadj_sub.f90 @@ -339,9 +339,9 @@ subroutine cc_fd_measure(file_prefix,tstart,tend) wtr_amp_bot = ampmax_bot * (wtr ** 2) endif do i = 1, nf - if(abs(bot_fdm(i)) > abs(wtr_amp_bot)) then + if (abs(bot_fdm(i)) > abs(wtr_amp_bot)) then trans_fdm(i) = top_fdm(i) / bot_fdm(i) - else if(abs(bot_fdm(i)) < abs(wtr_amp_bot)) then + else if (abs(bot_fdm(i)) < abs(wtr_amp_bot)) then trans_fdm(i) = top_fdm(i) / (bot_fdm(i)+wtr_amp_bot) endif enddo @@ -412,7 +412,7 @@ subroutine select_cc_fd_measure(tstart, tend, use_window) f_pmax = df * i_pmax T_pmax = 1./ f_pmax wlen = dt*nlen - if( ncycle_in_window * T_pmax > wlen ) then + if ( ncycle_in_window * T_pmax > wlen ) then use_window = .false. print *, 'rejecting window [', tstart, tend, ']' if (DEBUG) print *, ' wlen > ncycle * t_pmax= ', wlen, T_pmax diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/mtadj/mtadj_sub2.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/mtadj/mtadj_sub2.f90 index 40bc2e7b1..fee0d2bce 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/mtadj/mtadj_sub2.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/mtadj/mtadj_sub2.f90 @@ -26,9 +26,9 @@ subroutine compute_time_shift(synw,dataw,nlen,dt,ishift,tshift_cc) do i = -nlen, nlen, 1 cc = 0. do j = 1, nlen - if((j+i) >= 1 .and. (j+i) <= nlen) cc = cc + synw(j) * dataw(j+i) + if ((j+i) >= 1 .and. (j+i) <= nlen) cc = cc + synw(j) * dataw(j+i) enddo - if(cc > cc_max) then + if (cc > cc_max) then cc_max = cc ishift = i endif @@ -167,13 +167,13 @@ subroutine compute_dtau_dlnA(trans_fdm,dt,tshift_cc,dtau_fdm,dlnA_fdm,i_right) smth = phi_wt(i+1) + phi_wt(i-1) - 2.0 * phi_wt(i) smth1 = (phi_wt(i+1) + TWOPI) + phi_wt(i-1) - 2.0 * phi_wt(i) smth2 = (phi_wt(i+1) - TWOPI) + phi_wt(i-1) - 2.0 * phi_wt(i) - if(abs(smth1) PHASE_STEP)then + if (abs(smth1) PHASE_STEP) then if (DEBUG) print *, '2 pi phase correction:', fvec(i), phi_wt(i) - phi_wt(i+1) do j = i+1, i_right phi_wt(j) = phi_wt(j) + TWOPI enddo endif - if(abs(smth2) PHASE_STEP)then + if (abs(smth2) PHASE_STEP) then if (DEBUG) print *, '-2 pi phase correction:', fvec(i), phi_wt(i) - phi_wt(i+1) do j = i+1, i_right phi_wt(j) = phi_wt(j) - TWOPI @@ -213,7 +213,7 @@ subroutine compute_mt_error(ntaper,dataw,synw,tas,& bot_mtm(:) = cmplx(0.,0.) do ictaper = 1, ntaper - if(ictaper==iom) cycle + if (ictaper==iom) cycle ! apply ictaper'th taper datawt(1:nlen) = dataw(1:nlen) * tas(1:nlen,ictaper) @@ -242,8 +242,8 @@ subroutine compute_mt_error(ntaper,dataw,synw,tas,& ! calculate transfer function using water level do i = 1, i_right - if(abs(bot_mtm(i)) >= abs(wtr_amp_bot)) trans_mtm(i) = top_mtm(i) / bot_mtm(i) - if(abs(bot_mtm(i)) < abs(wtr_amp_bot)) trans_mtm(i) = top_mtm(i) /(bot_mtm(i)+wtr_amp_bot) + if (abs(bot_mtm(i)) >= abs(wtr_amp_bot)) trans_mtm(i) = top_mtm(i) / bot_mtm(i) + if (abs(bot_mtm(i)) < abs(wtr_amp_bot)) trans_mtm(i) = top_mtm(i) /(bot_mtm(i)+wtr_amp_bot) enddo call compute_dtau_dlnA(trans_mtm,dt,tshift_cc,dtau_mtm(:,iom),dlnA_mtm(:,iom),i_right) enddo ! iom diff --git a/utils/ADJOINT_TOMOGRAPHY_TOOLS/mtadj/mtadj_sub3.f90 b/utils/ADJOINT_TOMOGRAPHY_TOOLS/mtadj/mtadj_sub3.f90 index 5c50625a8..767911a2d 100644 --- a/utils/ADJOINT_TOMOGRAPHY_TOOLS/mtadj/mtadj_sub3.f90 +++ b/utils/ADJOINT_TOMOGRAPHY_TOOLS/mtadj/mtadj_sub3.f90 @@ -36,7 +36,7 @@ subroutine fft(n,xi,zzign,dt) integer :: l,iblock,nblock,i,lbhalf,j,lx ! sign must be +1. or -1. - if(zzign >= 0.) then + if (zzign >= 0.) then zign = 1. else zign = -1. @@ -69,23 +69,23 @@ subroutine fft(n,xi,zzign,dt) do 3 i=2,n ii = i - if(k < m(i)) go to 4 + if (k < m(i)) goto 4 3 k = k-m(i) 4 k = k+m(ii) k = 0 do 7 j=1,lx - if(k < j) go to 5 + if (k < j) goto 5 hold = xi(j) xi(j) = xi(k+1) xi(k+1) = hold 5 do 6 i=1,n ii = i - if(k < m(i)) go to 7 + if (k < m(i)) goto 7 6 k = k-m(i) 7 k = k+m(ii) ! final steps deal with dt factors - if(zign > 0.) then ! FORWARD FFT + if (zign > 0.) then ! FORWARD FFT do i = 1,lx xi(i) = xi(i)*dt ! multiplication by dt enddo @@ -186,7 +186,7 @@ subroutine staper(nt, fw, nev, v, ndim, a, w) r2 = sqrt(2.) - if(nt < 2) return + if (nt < 2) return nxi=mod(nt,2) lh=(nt/2)+nxi lp1=nt+1 @@ -196,7 +196,7 @@ subroutine staper(nt, fw, nev, v, ndim, a, w) do 10 i=1,lh a(i)=com*(i-hn)**2 10 w(i)=0.5*dble(i*(nt-i)) - if(nxi == 0) then + if (nxi == 0) then asav=a(lh)-w(lh) a(lh)=a(lh)+w(lh) rbd=1./(a(lh)+w(lh-1)) @@ -215,12 +215,12 @@ subroutine staper(nt, fw, nev, v, ndim, a, w) call tsturm(nt,lh,a,a(lh+1),w,neven,v,ndim,w(lh+1),0) do 20 i=1,neven k=2*i-1 - if(nxi == 1) v(lh,k)=r2*v(lh,k) + if (nxi == 1) v(lh,k)=r2*v(lh,k) do 20 j=1,lh 20 v(lp1-j,k)=v(j,k) - if(nodd <= 0) goto 34 + if (nodd <= 0) goto 34 ! Do the odd tapers - if(nxi == 0) then + if (nxi == 0) then a(lh)=asav*rbd else a(nt)=asav*rbd @@ -229,7 +229,7 @@ subroutine staper(nt, fw, nev, v, ndim, a, w) call tsturm(nt,lh-nxi,a,a(lh+1),w,nodd,v,ndim,w(lh+1),1) do 30 i=1,nodd k=2*i - if(nxi == 1) v(lh,k)=0. + if (nxi == 1) v(lh,k)=0. do 30 j=1,lh 30 v(lp1-j,k)=-v(j,k) 34 ntot=neven+nodd @@ -248,7 +248,7 @@ subroutine staper(nt, fw, nev, v, ndim, a, w) vmax=abs(v(1,m)) kmax=1 do 40 kk=2,lh - if(abs(v(kk,m)) <= vmax) goto 40 + if (abs(v(kk,m)) <= vmax) goto 40 kmax=kk vmax=abs(v(kk,m)) 40 continue @@ -290,35 +290,35 @@ subroutine tsturm(nt,n,a,b,w,nev,r,ndim,ev,ipar) !------------------------- - if(n <= 0.or.nev <= 0) return + if (n <= 0.or.nev <= 0) return umeps=1.-epsi do 5 i=1,nev 5 ev(i)=-1. u=1. do 1000 ik=1,nev - if(ik > 1) u=ev(ik-1)*umeps + if (ik > 1) u=ev(ik-1)*umeps el=min(ev(ik),u) 10 elam=0.5*(u+el) - if(abs(u-el) <= epsi1) goto 35 + if (abs(u-el) <= epsi1) goto 35 iag=0 q=a(1)-elam - if(q >= 0.) iag=iag+1 + if (q >= 0.) iag=iag+1 do 15 i=2,n - if(q == 0.) x=abs(b(i-1))/epsi - if(q /= 0.) x=w(i-1)/q + if (q == 0.) x=abs(b(i-1))/epsi + if (q /= 0.) x=w(i-1)/q q=a(i)-elam-x - if(q >= 0.) iag=iag+1 - if(iag > nev) goto 20 + if (q >= 0.) iag=iag+1 + if (iag > nev) goto 20 15 continue - if(iag >= ik) go to 20 + if (iag >= ik) goto 20 u=elam - go to 10 - 20 if(iag == ik) go to 30 + goto 10 + 20 if (iag == ik) goto 30 m=ik+1 do 25 i=m,iag 25 ev(i)=elam el=elam - go to 10 + goto 10 30 el=elam call root(u,el,elam,a,b,w,n,ik) 35 ev(ik)=elam @@ -358,30 +358,30 @@ subroutine root(u,el,elam,a,bb,w,n,ik) !---------------------- 5 elam=0.5*(u+el) - 10 if(abs(u-el) <= 1.5*epsi1) return + 10 if (abs(u-el) <= 1.5*epsi1) return an=a(1)-elam b=0. bn=-1./an iag=0 - if(an >= 0.) iag=iag+1 + if (an >= 0.) iag=iag+1 do 20 i=2,n - if(an == 0.) x=abs(bb(i-1))/epsi - if(an /= 0.) x=w(i-1)/an + if (an == 0.) x=abs(bb(i-1))/epsi + if (an /= 0.) x=w(i-1)/an an=a(i)-elam-x - if(an == 0.) an=epsi + if (an == 0.) an=epsi bm=b b=bn bn=((a(i)-elam)*b-bm*x-1.)/an - if(an >= 0.) iag=iag+1 + if (an >= 0.) iag=iag+1 20 continue - if(iag == ik) goto 25 + if (iag == ik) goto 25 u=elam goto 30 25 el=elam 30 del=1./bn - if(abs(del) <= epsi1) del=sign(epsi1,del) + if (abs(del) <= epsi1) del=sign(epsi1,del) elam=elam-del - if(elam >= u.or.elam <= el) goto 5 + if (elam >= u.or.elam <= el) goto 5 goto 10 end subroutine root @@ -495,7 +495,7 @@ subroutine taper (a, n, start, end, b) an = n m1 = an*start+0.5 m2 = m1 + 1 - if(m1 > 0) then + if (m1 > 0) then ang = 3.1415926 / float(m1) do i=1, m1 xi = i @@ -508,7 +508,7 @@ subroutine taper (a, n, start, end, b) m5 = n-m3 m4 = m5 + 1 - if(m3 > 0) then + if (m3 > 0) then ang = 3.1415926 / float (m3) do i=m4,n xi = i-n-1 diff --git a/utils/CPML/add_CPML_layers_to_an_existing_mesh.f90 b/utils/CPML/add_CPML_layers_to_an_existing_mesh.f90 index 9c5fae418..86aa6e93f 100644 --- a/utils/CPML/add_CPML_layers_to_an_existing_mesh.f90 +++ b/utils/CPML/add_CPML_layers_to_an_existing_mesh.f90 @@ -97,19 +97,19 @@ program add_CPML_layers_to_a_given_mesh print *,' (if not, you can run xconvert_mesh_files_from_ASCII_to_binary)' print *,'3 = exit' read(*,*) iformat - if(iformat /= 1 .and. iformat /= 2) stop 'exiting...' + if (iformat /= 1 .and. iformat /= 2) stop 'exiting...' print *,'enter the number of PML layers to add on each side of the mesh (usually 3, can also be 4):' read(*,*) NUMBER_OF_PML_LAYERS_TO_ADD - if(NUMBER_OF_PML_LAYERS_TO_ADD < 1) stop 'NUMBER_OF_PML_LAYERS_TO_ADD must be >= 1' + if (NUMBER_OF_PML_LAYERS_TO_ADD < 1) stop 'NUMBER_OF_PML_LAYERS_TO_ADD must be >= 1' print * print *,'1 = use a free surface at the top of the mesh i.e. do not add a CPML layer at the top (most classical option)' print *,'2 = add a CPML absorbing layer at the top of the mesh (less classical option)' print *,'3 = exit' read(*,*) iflag - if(iflag /= 1 .and. iflag /= 2) stop 'exiting...' - if(iflag == 1) then + if (iflag /= 1 .and. iflag /= 2) stop 'exiting...' + if (iflag == 1) then ALSO_ADD_ON_THE_TOP_SURFACE = .false. else ALSO_ADD_ON_THE_TOP_SURFACE = .true. @@ -120,39 +120,39 @@ program add_CPML_layers_to_a_given_mesh print *,'2 = enter the size of the PML elements to add manually' print *,'3 = exit' read(*,*) icompute_size - if(icompute_size /= 1 .and. icompute_size /= 2) stop 'exiting...' + if (icompute_size /= 1 .and. icompute_size /= 2) stop 'exiting...' - if(icompute_size == 2) then + if (icompute_size == 2) then print *,'enter the X size (in meters) of each CPML element to add on the Xmin face:' read(*,*) SIZE_OF_XMIN_ELEMENT_TO_ADD - if(SIZE_OF_XMIN_ELEMENT_TO_ADD <= 0.d0) stop 'SIZE_OF_XMIN_ELEMENT_TO_ADD must be > 0' + if (SIZE_OF_XMIN_ELEMENT_TO_ADD <= 0.d0) stop 'SIZE_OF_XMIN_ELEMENT_TO_ADD must be > 0' print * print *,'enter the X size (in meters) of each CPML element to add on the Xmax face:' read(*,*) SIZE_OF_XMAX_ELEMENT_TO_ADD - if(SIZE_OF_XMAX_ELEMENT_TO_ADD <= 0.d0) stop 'SIZE_OF_XMAX_ELEMENT_TO_ADD must be > 0' + if (SIZE_OF_XMAX_ELEMENT_TO_ADD <= 0.d0) stop 'SIZE_OF_XMAX_ELEMENT_TO_ADD must be > 0' print * print *,'enter the Y size (in meters) of each CPML element to add on the Ymin faces:' read(*,*) SIZE_OF_YMIN_ELEMENT_TO_ADD - if(SIZE_OF_YMIN_ELEMENT_TO_ADD <= 0.d0) stop 'SIZE_OF_YMIN_ELEMENT_TO_ADD must be > 0' + if (SIZE_OF_YMIN_ELEMENT_TO_ADD <= 0.d0) stop 'SIZE_OF_YMIN_ELEMENT_TO_ADD must be > 0' print * print *,'enter the Y size (in meters) of each CPML element to add on the Ymax faces:' read(*,*) SIZE_OF_YMAX_ELEMENT_TO_ADD - if(SIZE_OF_YMAX_ELEMENT_TO_ADD <= 0.d0) stop 'SIZE_OF_YMAX_ELEMENT_TO_ADD must be > 0' + if (SIZE_OF_YMAX_ELEMENT_TO_ADD <= 0.d0) stop 'SIZE_OF_YMAX_ELEMENT_TO_ADD must be > 0' print * print *,'enter the Z size (in meters) of each CPML element to add on the Zmin faces:' read(*,*) SIZE_OF_ZMIN_ELEMENT_TO_ADD - if(SIZE_OF_ZMIN_ELEMENT_TO_ADD <= 0.d0) stop 'SIZE_OF_ZMIN_ELEMENT_TO_ADD must be > 0' + if (SIZE_OF_ZMIN_ELEMENT_TO_ADD <= 0.d0) stop 'SIZE_OF_ZMIN_ELEMENT_TO_ADD must be > 0' print * - if(ALSO_ADD_ON_THE_TOP_SURFACE) then + if (ALSO_ADD_ON_THE_TOP_SURFACE) then print *,'enter the Z size (in meters) of each CPML element to add on the Zmax faces:' read(*,*) SIZE_OF_ZMAX_ELEMENT_TO_ADD - if(SIZE_OF_ZMAX_ELEMENT_TO_ADD <= 0.d0) stop 'SIZE_OF_ZMAX_ELEMENT_TO_ADD must be > 0' + if (SIZE_OF_ZMAX_ELEMENT_TO_ADD <= 0.d0) stop 'SIZE_OF_ZMAX_ELEMENT_TO_ADD must be > 0' print * endif @@ -165,7 +165,7 @@ program add_CPML_layers_to_a_given_mesh call get_shape3D(dershape3D,xigll,yigll,zigll,NGNOD,NGLLX,NGLLY,NGLLZ,NDIM) ! open SPECFEM3D_Cartesian mesh file to read the points - if(iformat == 1) then + if (iformat == 1) then open(unit=23,file='nodes_coords_file',status='old',action='read') read(23,*) npoin else @@ -175,7 +175,7 @@ program add_CPML_layers_to_a_given_mesh allocate(x(npoin)) allocate(y(npoin)) allocate(z(npoin)) - if(iformat == 1) then + if (iformat == 1) then do ipoin = 1,npoin read(23,*) ipoin_read,xread,yread,zread x(ipoin_read) = xread @@ -192,7 +192,7 @@ program add_CPML_layers_to_a_given_mesh ! ************* read mesh elements ************* ! open SPECFEM3D_Cartesian topology file to read the mesh elements - if(iformat == 1) then + if (iformat == 1) then open(unit=23,file='mesh_file',status='old',action='read') read(23,*) nspec else @@ -203,7 +203,7 @@ program add_CPML_layers_to_a_given_mesh allocate(ibool(NGNOD,nspec)) ! loop on the whole mesh - if(iformat == 1) then + if (iformat == 1) then do ispec_loop = 1,nspec read(23,*) ispec,i1,i2,i3,i4,i5,i6,i7,i8 ! store the ibool() array read @@ -226,13 +226,13 @@ program add_CPML_layers_to_a_given_mesh ! read the materials file allocate(imaterial(nspec)) - if(iformat == 1) then + if (iformat == 1) then open(unit=23,file='materials_file',status='old',action='read') else open(unit=23,file='materials_file.bin',form='unformatted',status='old',action='read') endif ! loop on the whole mesh - if(iformat == 1) then + if (iformat == 1) then do ispec_loop = 1,nspec read(23,*) ispec,i1 ! store the imaterial() array read @@ -252,15 +252,15 @@ program add_CPML_layers_to_a_given_mesh do iloop_on_min_face_then_max_face = 1,2 ! 1 is min face and 2 is max face (Xmin then Xmax, Ymin then Ymax, or Zmin then Zmax) ! do not add a CPML layer on the top surface if the user asked not to - if(iloop_on_X_Y_Z_faces == 3 .and. iloop_on_min_face_then_max_face == 2 .and. .not. ALSO_ADD_ON_THE_TOP_SURFACE) cycle + if (iloop_on_X_Y_Z_faces == 3 .and. iloop_on_min_face_then_max_face == 2 .and. .not. ALSO_ADD_ON_THE_TOP_SURFACE) cycle print * print *,'********************************************************************' - if(iloop_on_X_Y_Z_faces == 1) then + if (iloop_on_X_Y_Z_faces == 1) then print *,'adding CPML elements along one of the two X faces of the existing mesh' - else if(iloop_on_X_Y_Z_faces == 2) then + else if (iloop_on_X_Y_Z_faces == 2) then print *,'adding CPML elements along one of the two Y faces of the existing mesh' - else if(iloop_on_X_Y_Z_faces == 3) then + else if (iloop_on_X_Y_Z_faces == 3) then print *,'adding CPML elements along one of the two Z faces of the existing mesh' else stop 'wrong index in loop on faces' @@ -294,21 +294,21 @@ program add_CPML_layers_to_a_given_mesh count_elem_faces_to_extend = 0 - if(iloop_on_X_Y_Z_faces == 1) then ! Xmin or Xmax face + if (iloop_on_X_Y_Z_faces == 1) then ! Xmin or Xmax face value_min = xmin value_max = xmax value_size = xsize coord_to_use1 => x ! make coordinate array to use point to array x() coord_to_use2 => y coord_to_use3 => z - else if(iloop_on_X_Y_Z_faces == 2) then ! Ymin or Ymax face + else if (iloop_on_X_Y_Z_faces == 2) then ! Ymin or Ymax face value_min = ymin value_max = ymax value_size = ysize coord_to_use1 => y ! make coordinate array to use point to array y() coord_to_use2 => x coord_to_use3 => z - else if(iloop_on_X_Y_Z_faces == 3) then ! Zmin or Zmax face + else if (iloop_on_X_Y_Z_faces == 3) then ! Zmin or Zmax face value_min = zmin value_max = zmax value_size = zsize @@ -319,7 +319,7 @@ program add_CPML_layers_to_a_given_mesh stop 'wrong index in loop on faces' endif - if(minval(ibool) /= 1) stop 'error in minval(ibool)' + if (minval(ibool) /= 1) stop 'error in minval(ibool)' sum_of_distances = 0.d0 @@ -335,13 +335,13 @@ program add_CPML_layers_to_a_given_mesh i7 = ibool(7,ispec) i8 = ibool(8,ispec) - if(iloop_on_min_face_then_max_face == 1) then ! min face + if (iloop_on_min_face_then_max_face == 1) then ! min face ! detect elements belonging to the min face limit = value_min + value_size * SMALL_RELATIVE_VALUE ! test face 1 (bottom) - if(coord_to_use1(i1) < limit .and. coord_to_use1(i2) < limit .and. & + if (coord_to_use1(i1) < limit .and. coord_to_use1(i2) < limit .and. & coord_to_use1(i3) < limit .and. coord_to_use1(i4) < limit) then count_elem_faces_to_extend = count_elem_faces_to_extend + 1 sum_of_distances = sum_of_distances + & @@ -349,7 +349,7 @@ program add_CPML_layers_to_a_given_mesh endif ! test face 2 (top) - if(coord_to_use1(i5) < limit .and. coord_to_use1(i6) < limit .and. & + if (coord_to_use1(i5) < limit .and. coord_to_use1(i6) < limit .and. & coord_to_use1(i7) < limit .and. coord_to_use1(i8) < limit) then count_elem_faces_to_extend = count_elem_faces_to_extend + 1 sum_of_distances = sum_of_distances + & @@ -357,7 +357,7 @@ program add_CPML_layers_to_a_given_mesh endif ! test face 3 (left) - if(coord_to_use1(i1) < limit .and. coord_to_use1(i4) < limit .and. & + if (coord_to_use1(i1) < limit .and. coord_to_use1(i4) < limit .and. & coord_to_use1(i8) < limit .and. coord_to_use1(i5) < limit) then count_elem_faces_to_extend = count_elem_faces_to_extend + 1 sum_of_distances = sum_of_distances + & @@ -365,7 +365,7 @@ program add_CPML_layers_to_a_given_mesh endif ! test face 4 (right) - if(coord_to_use1(i2) < limit .and. coord_to_use1(i3) < limit .and. & + if (coord_to_use1(i2) < limit .and. coord_to_use1(i3) < limit .and. & coord_to_use1(i7) < limit .and. coord_to_use1(i6) < limit) then count_elem_faces_to_extend = count_elem_faces_to_extend + 1 sum_of_distances = sum_of_distances + & @@ -373,7 +373,7 @@ program add_CPML_layers_to_a_given_mesh endif ! test face 5 (front) - if(coord_to_use1(i1) < limit .and. coord_to_use1(i2) < limit .and. & + if (coord_to_use1(i1) < limit .and. coord_to_use1(i2) < limit .and. & coord_to_use1(i6) < limit .and. coord_to_use1(i5) < limit) then count_elem_faces_to_extend = count_elem_faces_to_extend + 1 sum_of_distances = sum_of_distances + & @@ -381,7 +381,7 @@ program add_CPML_layers_to_a_given_mesh endif ! test face 6 (back) - if(coord_to_use1(i4) < limit .and. coord_to_use1(i3) < limit .and. & + if (coord_to_use1(i4) < limit .and. coord_to_use1(i3) < limit .and. & coord_to_use1(i7) < limit .and. coord_to_use1(i8) < limit) then count_elem_faces_to_extend = count_elem_faces_to_extend + 1 sum_of_distances = sum_of_distances + & @@ -394,7 +394,7 @@ program add_CPML_layers_to_a_given_mesh limit = value_max - value_size * SMALL_RELATIVE_VALUE ! test face 1 (bottom) - if(coord_to_use1(i1) > limit .and. coord_to_use1(i2) > limit .and. & + if (coord_to_use1(i1) > limit .and. coord_to_use1(i2) > limit .and. & coord_to_use1(i3) > limit .and. coord_to_use1(i4) > limit) then count_elem_faces_to_extend = count_elem_faces_to_extend + 1 sum_of_distances = sum_of_distances + & @@ -402,7 +402,7 @@ program add_CPML_layers_to_a_given_mesh endif ! test face 2 (top) - if(coord_to_use1(i5) > limit .and. coord_to_use1(i6) > limit .and. & + if (coord_to_use1(i5) > limit .and. coord_to_use1(i6) > limit .and. & coord_to_use1(i7) > limit .and. coord_to_use1(i8) > limit) then count_elem_faces_to_extend = count_elem_faces_to_extend + 1 sum_of_distances = sum_of_distances + & @@ -410,7 +410,7 @@ program add_CPML_layers_to_a_given_mesh endif ! test face 3 (left) - if(coord_to_use1(i1) > limit .and. coord_to_use1(i4) > limit .and. & + if (coord_to_use1(i1) > limit .and. coord_to_use1(i4) > limit .and. & coord_to_use1(i8) > limit .and. coord_to_use1(i5) > limit) then count_elem_faces_to_extend = count_elem_faces_to_extend + 1 sum_of_distances = sum_of_distances + & @@ -418,7 +418,7 @@ program add_CPML_layers_to_a_given_mesh endif ! test face 4 (right) - if(coord_to_use1(i2) > limit .and. coord_to_use1(i3) > limit .and. & + if (coord_to_use1(i2) > limit .and. coord_to_use1(i3) > limit .and. & coord_to_use1(i7) > limit .and. coord_to_use1(i6) > limit) then count_elem_faces_to_extend = count_elem_faces_to_extend + 1 sum_of_distances = sum_of_distances + & @@ -426,7 +426,7 @@ program add_CPML_layers_to_a_given_mesh endif ! test face 5 (front) - if(coord_to_use1(i1) > limit .and. coord_to_use1(i2) > limit .and. & + if (coord_to_use1(i1) > limit .and. coord_to_use1(i2) > limit .and. & coord_to_use1(i6) > limit .and. coord_to_use1(i5) > limit) then count_elem_faces_to_extend = count_elem_faces_to_extend + 1 sum_of_distances = sum_of_distances + & @@ -434,7 +434,7 @@ program add_CPML_layers_to_a_given_mesh endif ! test face 6 (back) - if(coord_to_use1(i4) > limit .and. coord_to_use1(i3) > limit .and. & + if (coord_to_use1(i4) > limit .and. coord_to_use1(i3) > limit .and. & coord_to_use1(i7) > limit .and. coord_to_use1(i8) > limit) then count_elem_faces_to_extend = count_elem_faces_to_extend + 1 sum_of_distances = sum_of_distances + & @@ -447,14 +447,14 @@ program add_CPML_layers_to_a_given_mesh print *,'Total number of elements in the mesh before extension = ',nspec print *,'Number of element faces to extend = ',count_elem_faces_to_extend - if(count_elem_faces_to_extend == 0) stop 'error: number of element faces to extend detected is zero!' + if (count_elem_faces_to_extend == 0) stop 'error: number of element faces to extend detected is zero!' ! we will add NUMBER_OF_PML_LAYERS_TO_ADD to each of the element faces detected that need to be extended nspec_new = nspec + count_elem_faces_to_extend * NUMBER_OF_PML_LAYERS_TO_ADD ! and each of these elements will have NGNOD points ! (some of them shared with other elements, but we do not care because they will be removed automatically by xdecompose_mesh) npoin_new = npoin + count_elem_faces_to_extend * NUMBER_OF_PML_LAYERS_TO_ADD * NGNOD print *,'Total number of elements in the mesh after extension = ',nspec_new - if(icompute_size == 1) then + if (icompute_size == 1) then mean_distance = sum_of_distances / dble(count_elem_faces_to_extend) print *,'Computed mean size of the elements to extend = ',mean_distance endif @@ -473,7 +473,7 @@ program add_CPML_layers_to_a_given_mesh ibool_new(:,1:nspec) = ibool(:,1:nspec) imaterial_new(1:nspec) = imaterial(1:nspec) - if(minval(ibool) /= 1) stop 'error in minval(ibool)' + if (minval(ibool) /= 1) stop 'error in minval(ibool)' ! allocate a new set of points, with multiples allocate(x_new(npoin_new)) @@ -504,13 +504,13 @@ program add_CPML_layers_to_a_given_mesh ! reset flag need_to_extend_this_element = .false. - if(iloop_on_min_face_then_max_face == 1) then ! min face + if (iloop_on_min_face_then_max_face == 1) then ! min face ! detect elements belonging to the min face limit = value_min + value_size * SMALL_RELATIVE_VALUE ! test face 1 (bottom) - if(coord_to_use1(i1) < limit .and. coord_to_use1(i2) < limit .and. & + if (coord_to_use1(i1) < limit .and. coord_to_use1(i2) < limit .and. & coord_to_use1(i3) < limit .and. coord_to_use1(i4) < limit) then need_to_extend_this_element = .true. p1 = i1 @@ -520,7 +520,7 @@ program add_CPML_layers_to_a_given_mesh endif ! test face 2 (top) - if(coord_to_use1(i5) < limit .and. coord_to_use1(i6) < limit .and. & + if (coord_to_use1(i5) < limit .and. coord_to_use1(i6) < limit .and. & coord_to_use1(i7) < limit .and. coord_to_use1(i8) < limit) then need_to_extend_this_element = .true. p1 = i5 @@ -530,7 +530,7 @@ program add_CPML_layers_to_a_given_mesh endif ! test face 3 (left) - if(coord_to_use1(i1) < limit .and. coord_to_use1(i4) < limit .and. & + if (coord_to_use1(i1) < limit .and. coord_to_use1(i4) < limit .and. & coord_to_use1(i5) < limit .and. coord_to_use1(i8) < limit) then need_to_extend_this_element = .true. p1 = i1 @@ -540,7 +540,7 @@ program add_CPML_layers_to_a_given_mesh endif ! test face 4 (right) - if(coord_to_use1(i2) < limit .and. coord_to_use1(i3) < limit .and. & + if (coord_to_use1(i2) < limit .and. coord_to_use1(i3) < limit .and. & coord_to_use1(i7) < limit .and. coord_to_use1(i6) < limit) then need_to_extend_this_element = .true. p1 = i2 @@ -550,7 +550,7 @@ program add_CPML_layers_to_a_given_mesh endif ! test face 5 (front) - if(coord_to_use1(i1) < limit .and. coord_to_use1(i2) < limit .and. & + if (coord_to_use1(i1) < limit .and. coord_to_use1(i2) < limit .and. & coord_to_use1(i6) < limit .and. coord_to_use1(i5) < limit) then need_to_extend_this_element = .true. p1 = i1 @@ -560,7 +560,7 @@ program add_CPML_layers_to_a_given_mesh endif ! test face 6 (back) - if(coord_to_use1(i4) < limit .and. coord_to_use1(i3) < limit .and. & + if (coord_to_use1(i4) < limit .and. coord_to_use1(i3) < limit .and. & coord_to_use1(i7) < limit .and. coord_to_use1(i8) < limit) then need_to_extend_this_element = .true. p1 = i4 @@ -575,7 +575,7 @@ program add_CPML_layers_to_a_given_mesh limit = value_max - value_size * SMALL_RELATIVE_VALUE ! test face 1 (bottom) - if(coord_to_use1(i1) > limit .and. coord_to_use1(i2) > limit .and. & + if (coord_to_use1(i1) > limit .and. coord_to_use1(i2) > limit .and. & coord_to_use1(i3) > limit .and. coord_to_use1(i4) > limit) then need_to_extend_this_element = .true. p1 = i1 @@ -585,7 +585,7 @@ program add_CPML_layers_to_a_given_mesh endif ! test face 2 (top) - if(coord_to_use1(i5) > limit .and. coord_to_use1(i6) > limit .and. & + if (coord_to_use1(i5) > limit .and. coord_to_use1(i6) > limit .and. & coord_to_use1(i7) > limit .and. coord_to_use1(i8) > limit) then need_to_extend_this_element = .true. p1 = i5 @@ -595,7 +595,7 @@ program add_CPML_layers_to_a_given_mesh endif ! test face 3 (left) - if(coord_to_use1(i1) > limit .and. coord_to_use1(i4) > limit .and. & + if (coord_to_use1(i1) > limit .and. coord_to_use1(i4) > limit .and. & coord_to_use1(i5) > limit .and. coord_to_use1(i8) > limit) then need_to_extend_this_element = .true. p1 = i1 @@ -605,7 +605,7 @@ program add_CPML_layers_to_a_given_mesh endif ! test face 4 (right) - if(coord_to_use1(i2) > limit .and. coord_to_use1(i3) > limit .and. & + if (coord_to_use1(i2) > limit .and. coord_to_use1(i3) > limit .and. & coord_to_use1(i7) > limit .and. coord_to_use1(i6) > limit) then need_to_extend_this_element = .true. p1 = i2 @@ -615,7 +615,7 @@ program add_CPML_layers_to_a_given_mesh endif ! test face 5 (front) - if(coord_to_use1(i1) > limit .and. coord_to_use1(i2) > limit .and. & + if (coord_to_use1(i1) > limit .and. coord_to_use1(i2) > limit .and. & coord_to_use1(i6) > limit .and. coord_to_use1(i5) > limit) then need_to_extend_this_element = .true. p1 = i1 @@ -625,7 +625,7 @@ program add_CPML_layers_to_a_given_mesh endif ! test face 6 (back) - if(coord_to_use1(i4) > limit .and. coord_to_use1(i3) > limit .and. & + if (coord_to_use1(i4) > limit .and. coord_to_use1(i3) > limit .and. & coord_to_use1(i7) > limit .and. coord_to_use1(i8) > limit) then need_to_extend_this_element = .true. p1 = i4 @@ -636,7 +636,7 @@ program add_CPML_layers_to_a_given_mesh endif - if(need_to_extend_this_element) then + if (need_to_extend_this_element) then ! create the NUMBER_OF_PML_LAYERS_TO_ADD new elements @@ -652,34 +652,34 @@ program add_CPML_layers_to_a_given_mesh SIZE_OF_Y_ELEMENT_TO_ADD = 0.d0 SIZE_OF_Z_ELEMENT_TO_ADD = 0.d0 - if(iloop_on_X_Y_Z_faces == 1) then ! Xmin or Xmax - if(iloop_on_min_face_then_max_face == 1) then ! min face + if (iloop_on_X_Y_Z_faces == 1) then ! Xmin or Xmax + if (iloop_on_min_face_then_max_face == 1) then ! min face factor_x = -1 - if(icompute_size == 1) SIZE_OF_XMIN_ELEMENT_TO_ADD = mean_distance + if (icompute_size == 1) SIZE_OF_XMIN_ELEMENT_TO_ADD = mean_distance SIZE_OF_X_ELEMENT_TO_ADD = SIZE_OF_XMIN_ELEMENT_TO_ADD else ! max face factor_x = +1 - if(icompute_size == 1) SIZE_OF_XMAX_ELEMENT_TO_ADD = mean_distance + if (icompute_size == 1) SIZE_OF_XMAX_ELEMENT_TO_ADD = mean_distance SIZE_OF_X_ELEMENT_TO_ADD = SIZE_OF_XMAX_ELEMENT_TO_ADD endif - else if(iloop_on_X_Y_Z_faces == 2) then - if(iloop_on_min_face_then_max_face == 1) then ! min face + else if (iloop_on_X_Y_Z_faces == 2) then + if (iloop_on_min_face_then_max_face == 1) then ! min face factor_y = -1 - if(icompute_size == 1) SIZE_OF_YMIN_ELEMENT_TO_ADD = mean_distance + if (icompute_size == 1) SIZE_OF_YMIN_ELEMENT_TO_ADD = mean_distance SIZE_OF_Y_ELEMENT_TO_ADD = SIZE_OF_YMIN_ELEMENT_TO_ADD else ! max face factor_y = +1 - if(icompute_size == 1) SIZE_OF_YMAX_ELEMENT_TO_ADD = mean_distance + if (icompute_size == 1) SIZE_OF_YMAX_ELEMENT_TO_ADD = mean_distance SIZE_OF_Y_ELEMENT_TO_ADD = SIZE_OF_YMAX_ELEMENT_TO_ADD endif - else if(iloop_on_X_Y_Z_faces == 3) then - if(iloop_on_min_face_then_max_face == 1) then ! min face + else if (iloop_on_X_Y_Z_faces == 3) then + if (iloop_on_min_face_then_max_face == 1) then ! min face factor_z = -1 - if(icompute_size == 1) SIZE_OF_ZMIN_ELEMENT_TO_ADD = mean_distance + if (icompute_size == 1) SIZE_OF_ZMIN_ELEMENT_TO_ADD = mean_distance SIZE_OF_Z_ELEMENT_TO_ADD = SIZE_OF_ZMIN_ELEMENT_TO_ADD else ! max face factor_z = +1 - if(icompute_size == 1) SIZE_OF_ZMAX_ELEMENT_TO_ADD = mean_distance + if (icompute_size == 1) SIZE_OF_ZMAX_ELEMENT_TO_ADD = mean_distance SIZE_OF_Z_ELEMENT_TO_ADD = SIZE_OF_ZMAX_ELEMENT_TO_ADD endif else @@ -815,16 +815,16 @@ program add_CPML_layers_to_a_given_mesh call calc_jacobian(xelm,yelm,zelm,dershape3D,found_a_negative_jacobian2,NDIM,NGNOD,NGLLX,NGLLY,NGLLZ) ! this should never happen, it is just a safety test - if(found_a_negative_jacobian1 .and. found_a_negative_jacobian2) & + if (found_a_negative_jacobian1 .and. found_a_negative_jacobian2) & stop 'error: found a negative Jacobian that could not be fixed' ! this should also never happen, it is just a second safety test - if(.not. found_a_negative_jacobian1 .and. .not. found_a_negative_jacobian2) & + if (.not. found_a_negative_jacobian1 .and. .not. found_a_negative_jacobian2) & stop 'strange error: both the element created and its mirrored version have a positive Jacobian!' ! if we have found that the original element has a negative Jacobian and its mirrored element is fine, ! swap the points so that we use that mirrored element in the final mesh saved to disk instead of the original one - if(found_a_negative_jacobian1) then + if (found_a_negative_jacobian1) then i1 = ibool_new(5,elem_counter) i2 = ibool_new(6,elem_counter) i3 = ibool_new(7,elem_counter) @@ -849,7 +849,7 @@ program add_CPML_layers_to_a_given_mesh enddo - if(minval(ibool_new) /= 1) stop 'error in minval(ibool_new)' + if (minval(ibool_new) /= 1) stop 'error in minval(ibool_new)' ! deallocate the original arrays deallocate(x,y,z) @@ -880,14 +880,14 @@ program add_CPML_layers_to_a_given_mesh deallocate(ibool_new) deallocate(imaterial_new) - if(minval(ibool) /= 1) stop 'error in minval(ibool)' + if (minval(ibool) /= 1) stop 'error in minval(ibool)' enddo ! of iloop_on_min_face_then_max_face loop on Xmin then Xmax, or Ymin then Ymax, or Zmin then Zmax ! end of loop on the three sets of faces to first add CPML elements along X, then along Y, then along Z enddo - if(iformat == 1) then ! write the output in ASCII format + if (iformat == 1) then ! write the output in ASCII format ! write the new points (overwrite the old file) open(unit=23,file='nodes_coords_file',status='old',action='write') @@ -947,7 +947,7 @@ program add_CPML_layers_to_a_given_mesh print *,'THICKNESS_OF_YMIN_PML = ',sngl(SIZE_OF_YMIN_ELEMENT_TO_ADD * NUMBER_OF_PML_LAYERS_TO_ADD) print *,'THICKNESS_OF_YMAX_PML = ',sngl(SIZE_OF_YMAX_ELEMENT_TO_ADD * NUMBER_OF_PML_LAYERS_TO_ADD) print *,'THICKNESS_OF_ZMIN_PML = ',sngl(SIZE_OF_ZMIN_ELEMENT_TO_ADD * NUMBER_OF_PML_LAYERS_TO_ADD) - if(ALSO_ADD_ON_THE_TOP_SURFACE) & + if (ALSO_ADD_ON_THE_TOP_SURFACE) & print *,'THICKNESS_OF_ZMAX_PML = ',sngl(SIZE_OF_ZMAX_ELEMENT_TO_ADD * NUMBER_OF_PML_LAYERS_TO_ADD) print * @@ -958,7 +958,7 @@ program add_CPML_layers_to_a_given_mesh write(23,*) SIZE_OF_YMIN_ELEMENT_TO_ADD * NUMBER_OF_PML_LAYERS_TO_ADD write(23,*) SIZE_OF_YMAX_ELEMENT_TO_ADD * NUMBER_OF_PML_LAYERS_TO_ADD write(23,*) SIZE_OF_ZMIN_ELEMENT_TO_ADD * NUMBER_OF_PML_LAYERS_TO_ADD - if(ALSO_ADD_ON_THE_TOP_SURFACE) then + if (ALSO_ADD_ON_THE_TOP_SURFACE) then write(23,*) SIZE_OF_ZMAX_ELEMENT_TO_ADD * NUMBER_OF_PML_LAYERS_TO_ADD else ! convention (negative value) to say that this Zmax absorbing edge is turned off diff --git a/utils/CPML/convert_external_layers_of_a_given_mesh_to_CPML_layers.f90 b/utils/CPML/convert_external_layers_of_a_given_mesh_to_CPML_layers.f90 index ed7db7a02..ca74aa7f9 100644 --- a/utils/CPML/convert_external_layers_of_a_given_mesh_to_CPML_layers.f90 +++ b/utils/CPML/convert_external_layers_of_a_given_mesh_to_CPML_layers.f90 @@ -95,15 +95,15 @@ program convert_mesh_to_CPML print *,' (if not, you can run xconvert_mesh_files_from_ASCII_to_binary)' print *,'3 = exit' read(*,*) iformat - if(iformat /= 1 .and. iformat /= 2) stop 'exiting...' + if (iformat /= 1 .and. iformat /= 2) stop 'exiting...' print * print *,'1 = use a free surface at the top of the mesh (most classical option)' print *,'2 = use a CPML absorbing layer at the top of the mesh (less classical option)' print *,'3 = exit' read(*,*) iflag - if(iflag /= 1 .and. iflag /= 2) stop 'exiting...' - if(iflag == 1) then + if (iflag /= 1 .and. iflag /= 2) stop 'exiting...' + if (iflag == 1) then ALSO_ADD_ON_THE_TOP_SURFACE = .false. else ALSO_ADD_ON_THE_TOP_SURFACE = .true. @@ -114,10 +114,10 @@ program convert_mesh_to_CPML print *,'2 = read them from a file created by the previous code, xconvert_external_layers_of_a_given_mesh_to_CPML_layers' print *,'3 = exit' read(*,*) iread - if(iread /= 1 .and. iread /= 2) stop 'exiting...' + if (iread /= 1 .and. iread /= 2) stop 'exiting...' ! open SPECFEM3D_Cartesian mesh file to read the points - if(iformat == 1) then + if (iformat == 1) then open(unit=23,file='nodes_coords_file',status='old',action='read') read(23,*) npoin else @@ -127,7 +127,7 @@ program convert_mesh_to_CPML allocate(x(npoin)) allocate(y(npoin)) allocate(z(npoin)) - if(iformat == 1) then + if (iformat == 1) then do ipoin = 1,npoin read(23,*) ipoin_read,xread,yread,zread x(ipoin_read) = xread @@ -156,7 +156,7 @@ program convert_mesh_to_CPML print *,'Zmin and Zmax of the mesh read = ',zmin,zmax print * - if(iread == 2) then + if (iread == 2) then ! read the thickness values from an existing text file open(unit=23,file='values_to_use_for_convert_external_layers_of_a_given_mesh_to_CPML_layers.txt',status='old',action='read') @@ -168,9 +168,9 @@ program convert_mesh_to_CPML read(23,*) THICKNESS_OF_ZMAX_PML close(23) ! check convention (negative value) that says that this Zmax absorbing edge is turned off - if(ALSO_ADD_ON_THE_TOP_SURFACE .and. THICKNESS_OF_ZMAX_PML <= 0) & + if (ALSO_ADD_ON_THE_TOP_SURFACE .and. THICKNESS_OF_ZMAX_PML <= 0) & stop 'negative thickness is not allowed; ALSO_ADD_ON_THE_TOP_SURFACE is maybe inconsistent with the previous code; exiting...' - if(.not. ALSO_ADD_ON_THE_TOP_SURFACE .and. THICKNESS_OF_ZMAX_PML > 0) & + if (.not. ALSO_ADD_ON_THE_TOP_SURFACE .and. THICKNESS_OF_ZMAX_PML > 0) & stop 'ALSO_ADD_ON_THE_TOP_SURFACE seems inconsistent with the previous code; exiting...' else @@ -181,49 +181,49 @@ program convert_mesh_to_CPML print *,'the comment printed above; if you think you have roundoff issues or very' print *,'slightly varying thickness, give 2% or 5% more here, but never less' read(*,*) THICKNESS_OF_XMIN_PML - if(THICKNESS_OF_XMIN_PML <= 0) stop 'negative thickness is not allowed; exiting...' - if(THICKNESS_OF_XMIN_PML > 0.30*(xmax - xmin)) & + if (THICKNESS_OF_XMIN_PML <= 0) stop 'negative thickness is not allowed; exiting...' + if (THICKNESS_OF_XMIN_PML > 0.30*(xmax - xmin)) & stop 'thickness of each CPML layer greater than 30% of the size of the mesh is not a good idea; exiting...' print * print *,'What is the exact thickness of the PML layer that you want' print *,'on the Xmax face of your mesh?' read(*,*) THICKNESS_OF_XMAX_PML - if(THICKNESS_OF_XMAX_PML <= 0) stop 'negative thickness is not allowed; exiting...' - if(THICKNESS_OF_XMAX_PML > 0.30*(xmax - xmin)) & + if (THICKNESS_OF_XMAX_PML <= 0) stop 'negative thickness is not allowed; exiting...' + if (THICKNESS_OF_XMAX_PML > 0.30*(xmax - xmin)) & stop 'thickness of each CPML layer greater than 30% of the size of the mesh is not a good idea; exiting...' print * print *,'What is the exact thickness of the PML layer that you want' print *,'on the Ymin face of your mesh?' read(*,*) THICKNESS_OF_YMIN_PML - if(THICKNESS_OF_YMIN_PML <= 0) stop 'negative thickness is not allowed; exiting...' - if(THICKNESS_OF_YMIN_PML > 0.30*(ymax - ymin)) & + if (THICKNESS_OF_YMIN_PML <= 0) stop 'negative thickness is not allowed; exiting...' + if (THICKNESS_OF_YMIN_PML > 0.30*(ymax - ymin)) & stop 'thickness of each CPML layer greater than 30% of the size of the mesh is not a good idea; exiting...' print * print *,'What is the exact thickness of the PML layer that you want' print *,'on the Ymax face of your mesh?' read(*,*) THICKNESS_OF_YMAX_PML - if(THICKNESS_OF_YMAX_PML <= 0) stop 'negative thickness is not allowed; exiting...' - if(THICKNESS_OF_YMAX_PML > 0.30*(ymax - ymin)) & + if (THICKNESS_OF_YMAX_PML <= 0) stop 'negative thickness is not allowed; exiting...' + if (THICKNESS_OF_YMAX_PML > 0.30*(ymax - ymin)) & stop 'thickness of each CPML layer greater than 30% of the size of the mesh is not a good idea; exiting...' print * print *,'What is the exact thickness of the PML layer that you want' print *,'on the Zmin face of your mesh?' read(*,*) THICKNESS_OF_ZMIN_PML - if(THICKNESS_OF_ZMIN_PML <= 0) stop 'negative thickness is not allowed; exiting...' - if(THICKNESS_OF_ZMIN_PML > 0.30*(zmax - zmin)) & + if (THICKNESS_OF_ZMIN_PML <= 0) stop 'negative thickness is not allowed; exiting...' + if (THICKNESS_OF_ZMIN_PML > 0.30*(zmax - zmin)) & stop 'thickness of each CPML layer greater than 30% of the size of the mesh is not a good idea; exiting...' print * - if(ALSO_ADD_ON_THE_TOP_SURFACE) then + if (ALSO_ADD_ON_THE_TOP_SURFACE) then print *,'What is the exact thickness of the PML layer that you want' print *,'on the Zmax face of your mesh?' read(*,*) THICKNESS_OF_ZMAX_PML - if(THICKNESS_OF_ZMAX_PML <= 0) stop 'negative thickness is not allowed; exiting...' - if(THICKNESS_OF_ZMAX_PML > 0.30*(zmax - zmin)) & + if (THICKNESS_OF_ZMAX_PML <= 0) stop 'negative thickness is not allowed; exiting...' + if (THICKNESS_OF_ZMAX_PML > 0.30*(zmax - zmin)) & stop 'thickness of each CPML layer greater than 30% of the size of the mesh is not a good idea; exiting...' print * endif @@ -233,7 +233,7 @@ program convert_mesh_to_CPML ! ************* read mesh elements and generate CPML flags ************* ! open SPECFEM3D_Cartesian topology file to read the mesh elements - if(iformat == 1) then + if (iformat == 1) then open(unit=23,file='mesh_file',status='old',action='read') read(23,*) nspec else @@ -252,7 +252,7 @@ program convert_mesh_to_CPML allocate(ibool(NGNOD,nspec)) ! loop on the whole mesh - if(iformat == 1) then + if (iformat == 1) then do ispec_loop = 1,nspec read(23,*) ispec,i1,i2,i3,i4,i5,i6,i7,i8 ! store the ibool() array read @@ -285,33 +285,33 @@ program convert_mesh_to_CPML ! Xmin CPML limit = xmin + THICKNESS_OF_XMIN_PML * SMALL_PERCENTAGE_TOLERANCE - if(x(i1) < limit .and. x(i2) < limit .and. x(i3) < limit .and. x(i4) < limit .and. & + if (x(i1) < limit .and. x(i2) < limit .and. x(i3) < limit .and. x(i4) < limit .and. & x(i5) < limit .and. x(i6) < limit .and. x(i7) < limit .and. x(i8) < limit) is_X_CPML(ispec) = .true. ! Xmax CPML limit = xmax - THICKNESS_OF_XMAX_PML * SMALL_PERCENTAGE_TOLERANCE - if(x(i1) > limit .and. x(i2) > limit .and. x(i3) > limit .and. x(i4) > limit .and. & + if (x(i1) > limit .and. x(i2) > limit .and. x(i3) > limit .and. x(i4) > limit .and. & x(i5) > limit .and. x(i6) > limit .and. x(i7) > limit .and. x(i8) > limit) is_X_CPML(ispec) = .true. ! Ymin CPML limit = ymin + THICKNESS_OF_YMIN_PML * SMALL_PERCENTAGE_TOLERANCE - if(y(i1) < limit .and. y(i2) < limit .and. y(i3) < limit .and. y(i4) < limit .and. & + if (y(i1) < limit .and. y(i2) < limit .and. y(i3) < limit .and. y(i4) < limit .and. & y(i5) < limit .and. y(i6) < limit .and. y(i7) < limit .and. y(i8) < limit) is_Y_CPML(ispec) = .true. ! Ymax CPML limit = ymax - THICKNESS_OF_YMAX_PML * SMALL_PERCENTAGE_TOLERANCE - if(y(i1) > limit .and. y(i2) > limit .and. y(i3) > limit .and. y(i4) > limit .and. & + if (y(i1) > limit .and. y(i2) > limit .and. y(i3) > limit .and. y(i4) > limit .and. & y(i5) > limit .and. y(i6) > limit .and. y(i7) > limit .and. y(i8) > limit) is_Y_CPML(ispec) = .true. ! Zmin CPML limit = zmin + THICKNESS_OF_ZMIN_PML * SMALL_PERCENTAGE_TOLERANCE - if(z(i1) < limit .and. z(i2) < limit .and. z(i3) < limit .and. z(i4) < limit .and. & + if (z(i1) < limit .and. z(i2) < limit .and. z(i3) < limit .and. z(i4) < limit .and. & z(i5) < limit .and. z(i6) < limit .and. z(i7) < limit .and. z(i8) < limit) is_Z_CPML(ispec) = .true. ! Zmax CPML - if(ALSO_ADD_ON_THE_TOP_SURFACE) then + if (ALSO_ADD_ON_THE_TOP_SURFACE) then limit = zmax - THICKNESS_OF_ZMAX_PML * SMALL_PERCENTAGE_TOLERANCE - if(z(i1) > limit .and. z(i2) > limit .and. z(i3) > limit .and. z(i4) > limit .and. & + if (z(i1) > limit .and. z(i2) > limit .and. z(i3) > limit .and. z(i4) > limit .and. & z(i5) > limit .and. z(i6) > limit .and. z(i7) > limit .and. z(i8) > limit) is_Z_CPML(ispec) = .true. endif @@ -322,15 +322,15 @@ program convert_mesh_to_CPML print *,'Found ',count(is_X_CPML),' X_CPML elements' print *,'Found ',count(is_Y_CPML),' Y_CPML elements' print *,'Found ',count(is_Z_CPML),' Z_CPML elements' - if(ALSO_ADD_ON_THE_TOP_SURFACE) print *,' (also converted the top surface from free surface to CPML)' + if (ALSO_ADD_ON_THE_TOP_SURFACE) print *,' (also converted the top surface from free surface to CPML)' print * - if(count(is_X_CPML) == 0 .or. count(is_Y_CPML) == 0 .or. count(is_Z_CPML) == 0) & + if (count(is_X_CPML) == 0 .or. count(is_Y_CPML) == 0 .or. count(is_Z_CPML) == 0) & stop 'error: no CPML elements detected on at least one of the sides!' number_of_CPML_elements = 0 do ispec=1,nspec - if(is_X_CPML(ispec) .or. is_Y_CPML(ispec) .or. is_Z_CPML(ispec)) & + if (is_X_CPML(ispec) .or. is_Y_CPML(ispec) .or. is_Z_CPML(ispec)) & number_of_CPML_elements = number_of_CPML_elements + 1 enddo print *,'Created a total of ',number_of_CPML_elements,' unique CPML elements' @@ -345,25 +345,25 @@ program convert_mesh_to_CPML ! write the CPML flag for each CPML element do ispec=1,nspec - if(is_X_CPML(ispec) .and. is_Y_CPML(ispec) .and. is_Z_CPML(ispec)) then + if (is_X_CPML(ispec) .and. is_Y_CPML(ispec) .and. is_Z_CPML(ispec)) then write(24,*) ispec,CPML_XYZ - else if(is_Y_CPML(ispec) .and. is_Z_CPML(ispec)) then + else if (is_Y_CPML(ispec) .and. is_Z_CPML(ispec)) then write(24,*) ispec,CPML_YZ_ONLY - else if(is_X_CPML(ispec) .and. is_Z_CPML(ispec)) then + else if (is_X_CPML(ispec) .and. is_Z_CPML(ispec)) then write(24,*) ispec,CPML_XZ_ONLY - else if(is_X_CPML(ispec) .and. is_Y_CPML(ispec)) then + else if (is_X_CPML(ispec) .and. is_Y_CPML(ispec)) then write(24,*) ispec,CPML_XY_ONLY - else if(is_Z_CPML(ispec)) then + else if (is_Z_CPML(ispec)) then write(24,*) ispec,CPML_Z_ONLY - else if(is_Y_CPML(ispec)) then + else if (is_Y_CPML(ispec)) then write(24,*) ispec,CPML_Y_ONLY - else if(is_X_CPML(ispec)) then + else if (is_X_CPML(ispec)) then write(24,*) ispec,CPML_X_ONLY endif @@ -396,47 +396,47 @@ program convert_mesh_to_CPML i7 = ibool(7,ispec) i8 = ibool(8,ispec) - if(is_X_CPML(ispec)) then + if (is_X_CPML(ispec)) then already_found_a_face = .false. ! test face 1 (bottom) - if(x(i1) < limit .and. x(i2) < limit .and. x(i3) < limit .and. x(i4) < limit) then + if (x(i1) < limit .and. x(i2) < limit .and. x(i3) < limit .and. x(i4) < limit) then count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif ! test face 2 (top) - if(x(i5) < limit .and. x(i6) < limit .and. x(i7) < limit .and. x(i8) < limit) then - if(already_found_a_face) stop 'error: element with two faces on the same PML edge found!' + if (x(i5) < limit .and. x(i6) < limit .and. x(i7) < limit .and. x(i8) < limit) then + if (already_found_a_face) stop 'error: element with two faces on the same PML edge found!' count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif ! test face 3 (left) - if(x(i1) < limit .and. x(i4) < limit .and. x(i8) < limit .and. x(i5) < limit) then - if(already_found_a_face) stop 'error: element with two faces on the same PML edge found!' + if (x(i1) < limit .and. x(i4) < limit .and. x(i8) < limit .and. x(i5) < limit) then + if (already_found_a_face) stop 'error: element with two faces on the same PML edge found!' count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif ! test face 4 (right) - if(x(i2) < limit .and. x(i3) < limit .and. x(i7) < limit .and. x(i6) < limit) then - if(already_found_a_face) stop 'error: element with two faces on the same PML edge found!' + if (x(i2) < limit .and. x(i3) < limit .and. x(i7) < limit .and. x(i6) < limit) then + if (already_found_a_face) stop 'error: element with two faces on the same PML edge found!' count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif ! test face 5 (front) - if(x(i1) < limit .and. x(i2) < limit .and. x(i6) < limit .and. x(i5) < limit) then - if(already_found_a_face) stop 'error: element with two faces on the same PML edge found!' + if (x(i1) < limit .and. x(i2) < limit .and. x(i6) < limit .and. x(i5) < limit) then + if (already_found_a_face) stop 'error: element with two faces on the same PML edge found!' count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif ! test face 6 (back) - if(x(i4) < limit .and. x(i3) < limit .and. x(i7) < limit .and. x(i8) < limit) then - if(already_found_a_face) stop 'error: element with two faces on the same PML edge found!' + if (x(i4) < limit .and. x(i3) < limit .and. x(i7) < limit .and. x(i8) < limit) then + if (already_found_a_face) stop 'error: element with two faces on the same PML edge found!' count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif @@ -467,33 +467,33 @@ program convert_mesh_to_CPML i7 = ibool(7,ispec) i8 = ibool(8,ispec) - if(is_X_CPML(ispec)) then + if (is_X_CPML(ispec)) then ! for the six faces below it is important to make sure we write the four points ! in an order for which the normal to the face points outwards ! test face 1 (bottom) - if(x(i1) < limit .and. x(i2) < limit .and. x(i3) < limit .and. x(i4) < limit) & + if (x(i1) < limit .and. x(i2) < limit .and. x(i3) < limit .and. x(i4) < limit) & write(24,*) ispec,i4,i3,i2,i1 ! test face 2 (top) - if(x(i5) < limit .and. x(i6) < limit .and. x(i7) < limit .and. x(i8) < limit) & + if (x(i5) < limit .and. x(i6) < limit .and. x(i7) < limit .and. x(i8) < limit) & write(24,*) ispec,i5,i6,i7,i8 ! test face 3 (left) - if(x(i1) < limit .and. x(i4) < limit .and. x(i8) < limit .and. x(i5) < limit) & + if (x(i1) < limit .and. x(i4) < limit .and. x(i8) < limit .and. x(i5) < limit) & write(24,*) ispec,i1,i5,i8,i4 ! test face 4 (right) - if(x(i2) < limit .and. x(i3) < limit .and. x(i7) < limit .and. x(i6) < limit) & + if (x(i2) < limit .and. x(i3) < limit .and. x(i7) < limit .and. x(i6) < limit) & write(24,*) ispec,i2,i3,i7,i6 ! test face 5 (front) - if(x(i1) < limit .and. x(i2) < limit .and. x(i6) < limit .and. x(i5) < limit) & + if (x(i1) < limit .and. x(i2) < limit .and. x(i6) < limit .and. x(i5) < limit) & write(24,*) ispec,i1,i2,i6,i5 ! test face 6 (back) - if(x(i4) < limit .and. x(i3) < limit .and. x(i7) < limit .and. x(i8) < limit) & + if (x(i4) < limit .and. x(i3) < limit .and. x(i7) < limit .and. x(i8) < limit) & write(24,*) ispec,i3,i4,i8,i7 endif @@ -527,47 +527,47 @@ program convert_mesh_to_CPML i7 = ibool(7,ispec) i8 = ibool(8,ispec) - if(is_X_CPML(ispec)) then + if (is_X_CPML(ispec)) then already_found_a_face = .false. ! test face 1 (bottom) - if(x(i1) > limit .and. x(i2) > limit .and. x(i3) > limit .and. x(i4) > limit) then + if (x(i1) > limit .and. x(i2) > limit .and. x(i3) > limit .and. x(i4) > limit) then count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif ! test face 2 (top) - if(x(i5) > limit .and. x(i6) > limit .and. x(i7) > limit .and. x(i8) > limit) then - if(already_found_a_face) stop 'error: element with two faces on the same PML edge found!' + if (x(i5) > limit .and. x(i6) > limit .and. x(i7) > limit .and. x(i8) > limit) then + if (already_found_a_face) stop 'error: element with two faces on the same PML edge found!' count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif ! test face 3 (left) - if(x(i1) > limit .and. x(i4) > limit .and. x(i8) > limit .and. x(i5) > limit) then - if(already_found_a_face) stop 'error: element with two faces on the same PML edge found!' + if (x(i1) > limit .and. x(i4) > limit .and. x(i8) > limit .and. x(i5) > limit) then + if (already_found_a_face) stop 'error: element with two faces on the same PML edge found!' count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif ! test face 4 (right) - if(x(i2) > limit .and. x(i3) > limit .and. x(i7) > limit .and. x(i6) > limit) then - if(already_found_a_face) stop 'error: element with two faces on the same PML edge found!' + if (x(i2) > limit .and. x(i3) > limit .and. x(i7) > limit .and. x(i6) > limit) then + if (already_found_a_face) stop 'error: element with two faces on the same PML edge found!' count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif ! test face 5 (front) - if(x(i1) > limit .and. x(i2) > limit .and. x(i6) > limit .and. x(i5) > limit) then - if(already_found_a_face) stop 'error: element with two faces on the same PML edge found!' + if (x(i1) > limit .and. x(i2) > limit .and. x(i6) > limit .and. x(i5) > limit) then + if (already_found_a_face) stop 'error: element with two faces on the same PML edge found!' count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif ! test face 6 (back) - if(x(i4) > limit .and. x(i3) > limit .and. x(i7) > limit .and. x(i8) > limit) then - if(already_found_a_face) stop 'error: element with two faces on the same PML edge found!' + if (x(i4) > limit .and. x(i3) > limit .and. x(i7) > limit .and. x(i8) > limit) then + if (already_found_a_face) stop 'error: element with two faces on the same PML edge found!' count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif @@ -597,33 +597,33 @@ program convert_mesh_to_CPML i7 = ibool(7,ispec) i8 = ibool(8,ispec) - if(is_X_CPML(ispec)) then + if (is_X_CPML(ispec)) then ! for the six faces below it is important to make sure we write the four points ! in an order for which the normal to the face points outwards ! test face 1 (bottom) - if(x(i1) > limit .and. x(i2) > limit .and. x(i3) > limit .and. x(i4) > limit) & + if (x(i1) > limit .and. x(i2) > limit .and. x(i3) > limit .and. x(i4) > limit) & write(24,*) ispec,i4,i3,i2,i1 ! test face 2 (top) - if(x(i5) > limit .and. x(i6) > limit .and. x(i7) > limit .and. x(i8) > limit) & + if (x(i5) > limit .and. x(i6) > limit .and. x(i7) > limit .and. x(i8) > limit) & write(24,*) ispec,i5,i6,i7,i8 ! test face 3 (left) - if(x(i1) > limit .and. x(i4) > limit .and. x(i8) > limit .and. x(i5) > limit) & + if (x(i1) > limit .and. x(i4) > limit .and. x(i8) > limit .and. x(i5) > limit) & write(24,*) ispec,i1,i5,i8,i4 ! test face 4 (right) - if(x(i2) > limit .and. x(i3) > limit .and. x(i7) > limit .and. x(i6) > limit) & + if (x(i2) > limit .and. x(i3) > limit .and. x(i7) > limit .and. x(i6) > limit) & write(24,*) ispec,i2,i3,i7,i6 ! test face 5 (front) - if(x(i1) > limit .and. x(i2) > limit .and. x(i6) > limit .and. x(i5) > limit) & + if (x(i1) > limit .and. x(i2) > limit .and. x(i6) > limit .and. x(i5) > limit) & write(24,*) ispec,i1,i2,i6,i5 ! test face 6 (back) - if(x(i4) > limit .and. x(i3) > limit .and. x(i7) > limit .and. x(i8) > limit) & + if (x(i4) > limit .and. x(i3) > limit .and. x(i7) > limit .and. x(i8) > limit) & write(24,*) ispec,i3,i4,i8,i7 endif @@ -657,47 +657,47 @@ program convert_mesh_to_CPML i7 = ibool(7,ispec) i8 = ibool(8,ispec) - if(is_Y_CPML(ispec)) then + if (is_Y_CPML(ispec)) then already_found_a_face = .false. ! test face 1 (bottom) - if(y(i1) < limit .and. y(i2) < limit .and. y(i3) < limit .and. y(i4) < limit) then + if (y(i1) < limit .and. y(i2) < limit .and. y(i3) < limit .and. y(i4) < limit) then count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif ! test face 2 (top) - if(y(i5) < limit .and. y(i6) < limit .and. y(i7) < limit .and. y(i8) < limit) then - if(already_found_a_face) stop 'error: element with two faces on the same PML edge found!' + if (y(i5) < limit .and. y(i6) < limit .and. y(i7) < limit .and. y(i8) < limit) then + if (already_found_a_face) stop 'error: element with two faces on the same PML edge found!' count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif ! test face 3 (left) - if(y(i1) < limit .and. y(i4) < limit .and. y(i8) < limit .and. y(i5) < limit) then - if(already_found_a_face) stop 'error: element with two faces on the same PML edge found!' + if (y(i1) < limit .and. y(i4) < limit .and. y(i8) < limit .and. y(i5) < limit) then + if (already_found_a_face) stop 'error: element with two faces on the same PML edge found!' count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif ! test face 4 (right) - if(y(i2) < limit .and. y(i3) < limit .and. y(i7) < limit .and. y(i6) < limit) then - if(already_found_a_face) stop 'error: element with two faces on the same PML edge found!' + if (y(i2) < limit .and. y(i3) < limit .and. y(i7) < limit .and. y(i6) < limit) then + if (already_found_a_face) stop 'error: element with two faces on the same PML edge found!' count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif ! test face 5 (front) - if(y(i1) < limit .and. y(i2) < limit .and. y(i6) < limit .and. y(i5) < limit) then - if(already_found_a_face) stop 'error: element with two faces on the same PML edge found!' + if (y(i1) < limit .and. y(i2) < limit .and. y(i6) < limit .and. y(i5) < limit) then + if (already_found_a_face) stop 'error: element with two faces on the same PML edge found!' count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif ! test face 6 (back) - if(y(i4) < limit .and. y(i3) < limit .and. y(i7) < limit .and. y(i8) < limit) then - if(already_found_a_face) stop 'error: element with two faces on the same PML edge found!' + if (y(i4) < limit .and. y(i3) < limit .and. y(i7) < limit .and. y(i8) < limit) then + if (already_found_a_face) stop 'error: element with two faces on the same PML edge found!' count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif @@ -727,33 +727,33 @@ program convert_mesh_to_CPML i7 = ibool(7,ispec) i8 = ibool(8,ispec) - if(is_Y_CPML(ispec)) then + if (is_Y_CPML(ispec)) then ! for the six faces below it is important to make sure we write the four points ! in an order for which the normal to the face points outwards ! test face 1 (bottom) - if(y(i1) < limit .and. y(i2) < limit .and. y(i3) < limit .and. y(i4) < limit) & + if (y(i1) < limit .and. y(i2) < limit .and. y(i3) < limit .and. y(i4) < limit) & write(24,*) ispec,i4,i3,i2,i1 ! test face 2 (top) - if(y(i5) < limit .and. y(i6) < limit .and. y(i7) < limit .and. y(i8) < limit) & + if (y(i5) < limit .and. y(i6) < limit .and. y(i7) < limit .and. y(i8) < limit) & write(24,*) ispec,i5,i6,i7,i8 ! test face 3 (left) - if(y(i1) < limit .and. y(i4) < limit .and. y(i8) < limit .and. y(i5) < limit) & + if (y(i1) < limit .and. y(i4) < limit .and. y(i8) < limit .and. y(i5) < limit) & write(24,*) ispec,i1,i5,i8,i4 ! test face 4 (right) - if(y(i2) < limit .and. y(i3) < limit .and. y(i7) < limit .and. y(i6) < limit) & + if (y(i2) < limit .and. y(i3) < limit .and. y(i7) < limit .and. y(i6) < limit) & write(24,*) ispec,i2,i3,i7,i6 ! test face 5 (front) - if(y(i1) < limit .and. y(i2) < limit .and. y(i6) < limit .and. y(i5) < limit) & + if (y(i1) < limit .and. y(i2) < limit .and. y(i6) < limit .and. y(i5) < limit) & write(24,*) ispec,i1,i2,i6,i5 ! test face 6 (back) - if(y(i4) < limit .and. y(i3) < limit .and. y(i7) < limit .and. y(i8) < limit) & + if (y(i4) < limit .and. y(i3) < limit .and. y(i7) < limit .and. y(i8) < limit) & write(24,*) ispec,i3,i4,i8,i7 endif @@ -787,47 +787,47 @@ program convert_mesh_to_CPML i7 = ibool(7,ispec) i8 = ibool(8,ispec) - if(is_Y_CPML(ispec)) then + if (is_Y_CPML(ispec)) then already_found_a_face = .false. ! test face 1 (bottom) - if(y(i1) > limit .and. y(i2) > limit .and. y(i3) > limit .and. y(i4) > limit) then + if (y(i1) > limit .and. y(i2) > limit .and. y(i3) > limit .and. y(i4) > limit) then count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif ! test face 2 (top) - if(y(i5) > limit .and. y(i6) > limit .and. y(i7) > limit .and. y(i8) > limit) then - if(already_found_a_face) stop 'error: element with two faces on the same PML edge found!' + if (y(i5) > limit .and. y(i6) > limit .and. y(i7) > limit .and. y(i8) > limit) then + if (already_found_a_face) stop 'error: element with two faces on the same PML edge found!' count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif ! test face 3 (left) - if(y(i1) > limit .and. y(i4) > limit .and. y(i8) > limit .and. y(i5) > limit) then - if(already_found_a_face) stop 'error: element with two faces on the same PML edge found!' + if (y(i1) > limit .and. y(i4) > limit .and. y(i8) > limit .and. y(i5) > limit) then + if (already_found_a_face) stop 'error: element with two faces on the same PML edge found!' count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif ! test face 4 (right) - if(y(i2) > limit .and. y(i3) > limit .and. y(i7) > limit .and. y(i6) > limit) then - if(already_found_a_face) stop 'error: element with two faces on the same PML edge found!' + if (y(i2) > limit .and. y(i3) > limit .and. y(i7) > limit .and. y(i6) > limit) then + if (already_found_a_face) stop 'error: element with two faces on the same PML edge found!' count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif ! test face 5 (front) - if(y(i1) > limit .and. y(i2) > limit .and. y(i6) > limit .and. y(i5) > limit) then - if(already_found_a_face) stop 'error: element with two faces on the same PML edge found!' + if (y(i1) > limit .and. y(i2) > limit .and. y(i6) > limit .and. y(i5) > limit) then + if (already_found_a_face) stop 'error: element with two faces on the same PML edge found!' count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif ! test face 6 (back) - if(y(i4) > limit .and. y(i3) > limit .and. y(i7) > limit .and. y(i8) > limit) then - if(already_found_a_face) stop 'error: element with two faces on the same PML edge found!' + if (y(i4) > limit .and. y(i3) > limit .and. y(i7) > limit .and. y(i8) > limit) then + if (already_found_a_face) stop 'error: element with two faces on the same PML edge found!' count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif @@ -857,33 +857,33 @@ program convert_mesh_to_CPML i7 = ibool(7,ispec) i8 = ibool(8,ispec) - if(is_Y_CPML(ispec)) then + if (is_Y_CPML(ispec)) then ! for the six faces below it is important to make sure we write the four points ! in an order for which the normal to the face points outwards ! test face 1 (bottom) - if(y(i1) > limit .and. y(i2) > limit .and. y(i3) > limit .and. y(i4) > limit) & + if (y(i1) > limit .and. y(i2) > limit .and. y(i3) > limit .and. y(i4) > limit) & write(24,*) ispec,i4,i3,i2,i1 ! test face 2 (top) - if(y(i5) > limit .and. y(i6) > limit .and. y(i7) > limit .and. y(i8) > limit) & + if (y(i5) > limit .and. y(i6) > limit .and. y(i7) > limit .and. y(i8) > limit) & write(24,*) ispec,i5,i6,i7,i8 ! test face 3 (left) - if(y(i1) > limit .and. y(i4) > limit .and. y(i8) > limit .and. y(i5) > limit) & + if (y(i1) > limit .and. y(i4) > limit .and. y(i8) > limit .and. y(i5) > limit) & write(24,*) ispec,i1,i5,i8,i4 ! test face 4 (right) - if(y(i2) > limit .and. y(i3) > limit .and. y(i7) > limit .and. y(i6) > limit) & + if (y(i2) > limit .and. y(i3) > limit .and. y(i7) > limit .and. y(i6) > limit) & write(24,*) ispec,i2,i3,i7,i6 ! test face 5 (front) - if(y(i1) > limit .and. y(i2) > limit .and. y(i6) > limit .and. y(i5) > limit) & + if (y(i1) > limit .and. y(i2) > limit .and. y(i6) > limit .and. y(i5) > limit) & write(24,*) ispec,i1,i2,i6,i5 ! test face 6 (back) - if(y(i4) > limit .and. y(i3) > limit .and. y(i7) > limit .and. y(i8) > limit) & + if (y(i4) > limit .and. y(i3) > limit .and. y(i7) > limit .and. y(i8) > limit) & write(24,*) ispec,i3,i4,i8,i7 endif @@ -917,47 +917,47 @@ program convert_mesh_to_CPML i7 = ibool(7,ispec) i8 = ibool(8,ispec) - if(is_Z_CPML(ispec)) then + if (is_Z_CPML(ispec)) then already_found_a_face = .false. ! test face 1 (bottom) - if(z(i1) < limit .and. z(i2) < limit .and. z(i3) < limit .and. z(i4) < limit) then + if (z(i1) < limit .and. z(i2) < limit .and. z(i3) < limit .and. z(i4) < limit) then count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif ! test face 2 (top) - if(z(i5) < limit .and. z(i6) < limit .and. z(i7) < limit .and. z(i8) < limit) then - if(already_found_a_face) stop 'error: element with two faces on the same PML edge found!' + if (z(i5) < limit .and. z(i6) < limit .and. z(i7) < limit .and. z(i8) < limit) then + if (already_found_a_face) stop 'error: element with two faces on the same PML edge found!' count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif ! test face 3 (left) - if(z(i1) < limit .and. z(i4) < limit .and. z(i8) < limit .and. z(i5) < limit) then - if(already_found_a_face) stop 'error: element with two faces on the same PML edge found!' + if (z(i1) < limit .and. z(i4) < limit .and. z(i8) < limit .and. z(i5) < limit) then + if (already_found_a_face) stop 'error: element with two faces on the same PML edge found!' count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif ! test face 4 (right) - if(z(i2) < limit .and. z(i3) < limit .and. z(i7) < limit .and. z(i6) < limit) then - if(already_found_a_face) stop 'error: element with two faces on the same PML edge found!' + if (z(i2) < limit .and. z(i3) < limit .and. z(i7) < limit .and. z(i6) < limit) then + if (already_found_a_face) stop 'error: element with two faces on the same PML edge found!' count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif ! test face 5 (front) - if(z(i1) < limit .and. z(i2) < limit .and. z(i6) < limit .and. z(i5) < limit) then - if(already_found_a_face) stop 'error: element with two faces on the same PML edge found!' + if (z(i1) < limit .and. z(i2) < limit .and. z(i6) < limit .and. z(i5) < limit) then + if (already_found_a_face) stop 'error: element with two faces on the same PML edge found!' count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif ! test face 6 (back) - if(z(i4) < limit .and. z(i3) < limit .and. z(i7) < limit .and. z(i8) < limit) then - if(already_found_a_face) stop 'error: element with two faces on the same PML edge found!' + if (z(i4) < limit .and. z(i3) < limit .and. z(i7) < limit .and. z(i8) < limit) then + if (already_found_a_face) stop 'error: element with two faces on the same PML edge found!' count_faces_found = count_faces_found + 1 already_found_a_face = .true. endif @@ -987,33 +987,33 @@ program convert_mesh_to_CPML i7 = ibool(7,ispec) i8 = ibool(8,ispec) - if(is_Z_CPML(ispec)) then + if (is_Z_CPML(ispec)) then ! for the six faces below it is important to make sure we write the four points ! in an order for which the normal to the face points outwards ! test face 1 (bottom) - if(z(i1) < limit .and. z(i2) < limit .and. z(i3) < limit .and. z(i4) < limit) & + if (z(i1) < limit .and. z(i2) < limit .and. z(i3) < limit .and. z(i4) < limit) & write(24,*) ispec,i4,i3,i2,i1 ! test face 2 (top) - if(z(i5) < limit .and. z(i6) < limit .and. z(i7) < limit .and. z(i8) < limit) & + if (z(i5) < limit .and. z(i6) < limit .and. z(i7) < limit .and. z(i8) < limit) & write(24,*) ispec,i5,i6,i7,i8 ! test face 3 (left) - if(z(i1) < limit .and. z(i4) < limit .and. z(i8) < limit .and. z(i5) < limit) & + if (z(i1) < limit .and. z(i4) < limit .and. z(i8) < limit .and. z(i5) < limit) & write(24,*) ispec,i1,i5,i8,i4 ! test face 4 (right) - if(z(i2) < limit .and. z(i3) < limit .and. z(i7) < limit .and. z(i6) < limit) & + if (z(i2) < limit .and. z(i3) < limit .and. z(i7) < limit .and. z(i6) < limit) & write(24,*) ispec,i2,i3,i7,i6 ! test face 5 (front) - if(z(i1) < limit .and. z(i2) < limit .and. z(i6) < limit .and. z(i5) < limit) & + if (z(i1) < limit .and. z(i2) < limit .and. z(i6) < limit .and. z(i5) < limit) & write(24,*) ispec,i1,i2,i6,i5 ! test face 6 (back) - if(z(i4) < limit .and. z(i3) < limit .and. z(i7) < limit .and. z(i8) < limit) & + if (z(i4) < limit .and. z(i3) < limit .and. z(i7) < limit .and. z(i8) < limit) & write(24,*) ispec,i3,i4,i8,i7 endif diff --git a/utils/CPML/shuffle_existing_mesh_for_tests.f90 b/utils/CPML/shuffle_existing_mesh_for_tests.f90 index e4000bbe6..4eb7196c7 100644 --- a/utils/CPML/shuffle_existing_mesh_for_tests.f90 +++ b/utils/CPML/shuffle_existing_mesh_for_tests.f90 @@ -51,17 +51,17 @@ program shuffle_existing_mesh_for_tests read(23,*) ispec,i1,i2,i3,i4,i5,i6,i7,i8 ! implement shuffling of the list of points, one possibility for each of the six faces of the reference cube - if(mod(ispec_loop,6) == 0) then + if (mod(ispec_loop,6) == 0) then write(24,"(i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9)") ispec,i1,i2,i3,i4,i5,i6,i7,i8 - else if(mod(ispec_loop,6) == 1) then + else if (mod(ispec_loop,6) == 1) then write(24,"(i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9)") ispec,i5,i1,i4,i8,i6,i2,i3,i7 - else if(mod(ispec_loop,6) == 2) then + else if (mod(ispec_loop,6) == 2) then write(24,"(i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9)") ispec,i8,i7,i6,i5,i4,i3,i2,i1 - else if(mod(ispec_loop,6) == 3) then + else if (mod(ispec_loop,6) == 3) then write(24,"(i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9)") ispec,i3,i2,i6,i7,i4,i1,i5,i8 - else if(mod(ispec_loop,6) == 4) then + else if (mod(ispec_loop,6) == 4) then write(24,"(i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9)") ispec,i4,i3,i7,i8,i1,i2,i6,i5 - else if(mod(ispec_loop,6) == 5) then + else if (mod(ispec_loop,6) == 5) then write(24,"(i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9)") ispec,i1,i5,i6,i2,i4,i8,i7,i3 else stop 'incorrect value of the shuffling index' diff --git a/utils/Cubit_or_Gmsh/convert_tetra_mesh_to_hexa_mesh_THex.f90 b/utils/Cubit_or_Gmsh/convert_tetra_mesh_to_hexa_mesh_THex.f90 index f7b129571..cc4ee14e1 100644 --- a/utils/Cubit_or_Gmsh/convert_tetra_mesh_to_hexa_mesh_THex.f90 +++ b/utils/Cubit_or_Gmsh/convert_tetra_mesh_to_hexa_mesh_THex.f90 @@ -120,7 +120,7 @@ program convert_tetra_mesh_to_hexa_mesh do i = 1,nglob read(10,*) iread,xread,yread,zread - if(iread < 1 .or. iread > nglob) stop 'incorrect point read' + if (iread < 1 .or. iread > nglob) stop 'incorrect point read' x(iread) = xread y(iread) = yread z(iread) = zread @@ -147,14 +147,14 @@ program convert_tetra_mesh_to_hexa_mesh do i = 1,nelem_in_file inode_read(:) = 0 ! read list of elements stored in new Gmsh 2.9.3 format or in old Gmsh 2.4.2 format (the old one has one extra dummy value) - if(USE_OLD_GMSH_MESH_FORMAT) then + if (USE_OLD_GMSH_MESH_FORMAT) then read(10,*) iread,itype,idummy1,idummy2,ivolume,idummy3,(inode_read(k), k=0,number_of_points_per_element_type(itype)-1) else read(10,*) iread,itype,idummy1,idummy2,ivolume,(inode_read(k), k=0,number_of_points_per_element_type(itype)-1) endif - if(number_of_points_per_element_type(itype) <= 0) stop 'incorrect element type read' - if(iread < 1 .or. iread > nelem_in_file) stop 'incorrect element read' - if(itype == 4) then + if (number_of_points_per_element_type(itype) <= 0) stop 'incorrect element type read' + if (iread < 1 .or. iread > nelem_in_file) stop 'incorrect element read' + if (itype == 4) then ntet = ntet + 1 endif enddo @@ -209,16 +209,16 @@ program convert_tetra_mesh_to_hexa_mesh inode_read(:) = 0 ! read list of elements stored in new Gmsh 2.9.3 format or in old Gmsh 2.4.2 format (the old one has one extra dummy value) - if(USE_OLD_GMSH_MESH_FORMAT) then + if (USE_OLD_GMSH_MESH_FORMAT) then read(10,*) iread,itype,idummy1,idummy2,ivolume,idummy3,(inode_read(k), k=0,number_of_points_per_element_type(itype)-1) else read(10,*) iread,itype,idummy1,idummy2,ivolume,(inode_read(k), k=0,number_of_points_per_element_type(itype)-1) endif - if(number_of_points_per_element_type(itype) <= 0) stop 'incorrect element type read' - if(iread < 1 .or. iread > nelem_in_file) stop 'incorrect element read' + if (number_of_points_per_element_type(itype) <= 0) stop 'incorrect element type read' + if (iread < 1 .or. iread > nelem_in_file) stop 'incorrect element read' ! processing only the elements that are tetrahedra - if(itype == 4) then + if (itype == 4) then ntet = ntet + 1 ! now let us cut each tetrahedron into four hexahedra using the middle of each edge, each face and the barycenter. diff --git a/utils/Visualization/Paraview/create_slice_VTK.f90 b/utils/Visualization/Paraview/create_slice_VTK.f90 index 11225ebb1..b684cecdf 100644 --- a/utils/Visualization/Paraview/create_slice_VTK.f90 +++ b/utils/Visualization/Paraview/create_slice_VTK.f90 @@ -76,7 +76,7 @@ program create_slice_VTK print *, ' - slice_list: file containing slice/proc ids ' print *, ' - filename: looks for filename.bin must be array of (NGLLX,NGLLY,NGLLZ,nspec)' print *, ' - input_dir: includes proc***_external_mesh.bin and proc****filename.bin ' - print *, ' - output_dir: output mesh files go to here ' + print *, ' - output_dir: output mesh files goto here ' print * stop ' Reenter command line options' endif @@ -129,12 +129,12 @@ program create_slice_VTK ! ibool file allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) - if( ier /= 0 ) stop 'error allocating array ibool' + if ( ier /= 0 ) stop 'error allocating array ibool' read(27) ibool ! global point arrays allocate(xstore(NGLOB_AB),ystore(NGLOB_AB),zstore(NGLOB_AB),stat=ier) - if( ier /= 0 ) stop 'error allocating array xstore etc.' + if ( ier /= 0 ) stop 'error allocating array xstore etc.' read(27) xstore read(27) ystore read(27) zstore @@ -152,7 +152,7 @@ program create_slice_VTK stop endif allocate(data(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) - if( ier /= 0 ) stop 'error allocating array data' + if ( ier /= 0 ) stop 'error allocating array data' read(28) data close(28) diff --git a/utils/Visualization/Paraview/visualize_gold/src/read_input.f90 b/utils/Visualization/Paraview/visualize_gold/src/read_input.f90 index cf948f620..3d8066605 100644 --- a/utils/Visualization/Paraview/visualize_gold/src/read_input.f90 +++ b/utils/Visualization/Paraview/visualize_gold/src/read_input.f90 @@ -33,7 +33,7 @@ subroutine read_input (inp_fname) ! open file to read open(unit=11,file=trim(inp_fname),status='old', action='read',iostat=ios) -if (ios /= 0)then +if (ios /= 0) then write(*,'(/,a)')'ERROR: input file "'//trim(inp_fname)//'" cannot be opened!' stop endif @@ -48,7 +48,7 @@ subroutine read_input (inp_fname) ! look for line continuation tag=trim(line) call last_char(line,tmp_char,ind) - if (tmp_char=='&')then + if (tmp_char=='&') then slen=len(line) tag=trim(line(1:ind-1)) read(11,'(a)',iostat=ios)line ! This will read a line and proceed to next line @@ -57,7 +57,7 @@ subroutine read_input (inp_fname) call first_token(tag,token) ! read input information - if (trim(token)=='input:')then + if (trim(token)=='input:') then call split_string(tag,',',args,narg) inp_path=get_string('path',args,narg) dt=get_real('dt',args,narg) @@ -66,11 +66,11 @@ subroutine read_input (inp_fname) t_inc=get_integer('step',args,narg) t_width=get_integer('width',args,narg) inp_ncomp=get_integer('ncomp',args,narg); allocate(inp_head(inp_ncomp)) - if (inp_ncomp==1)then + if (inp_ncomp==1) then inp_head=get_string('head',args,narg) - else if (inp_ncomp==3)then ! vector + else if (inp_ncomp==3) then ! vector inp_head=get_string_vect('head',inp_ncomp,args,narg) - else if (inp_ncomp==6)then ! tensor + else if (inp_ncomp==6) then ! tensor inp_head=get_string_vect('head',inp_ncomp,args,narg) else write(*,'(/,a)')'ERROR: wrong ncomp value in input: line!' @@ -84,7 +84,7 @@ subroutine read_input (inp_fname) endif ! read output information - if (trim(token)=='output:')then + if (trim(token)=='output:') then call split_string(tag,',',args,narg) !out_path=get_string('path',args,narg) call seek_string('path',strval,args,narg) @@ -101,7 +101,7 @@ subroutine read_input (inp_fname) endif ! read processor information - if (trim(token)=='procinfo:')then + if (trim(token)=='procinfo:') then call split_string(tag,',',args,narg) proc_head=get_string('head',args,narg) proc_width=get_integer('width',args,narg) @@ -109,7 +109,7 @@ subroutine read_input (inp_fname) slice_npmax=get_integer('npmax',args,narg) allocate(slice_nproc(out_nslice)) allocate(slice_proc_list(out_nslice,slice_npmax)) - if (out_format==1 .and. out_nslice>1)then + if (out_format==1 .and. out_nslice>1) then ! allocate memory for server_name and server_exec allocate(server_name(out_nslice)) allocate(server_exec(out_nslice)) @@ -119,26 +119,26 @@ subroutine read_input (inp_fname) endif ! read processor list - if (trim(token)=='proclist:')then + if (trim(token)=='proclist:') then proclist_stat=-1 call split_string(tag,',',args,narg) slice_count1=slice_count1+1 - if (slice_count1>out_nslice)then + if (slice_count1>out_nslice) then write(*,'(/,a)')'ERROR: number of slices exceeds the actual number!' stop endif slice_nproc(slice_count1)=get_integer('np',args,narg) proc_mode=get_integer('mode',args,narg) - if (proc_mode==0)then + if (proc_mode==0) then slice_proc_list(slice_count1,1:slice_nproc(slice_count1)) & =get_integer_vect('list',slice_nproc(slice_count1),args,narg) - else if (proc_mode==1)then ! Indicial + else if (proc_mode==1) then ! Indicial proc_ind=get_integer_vect('list',3,args,narg) ! start, end, step proc_count=0 do i_proc=proc_ind(1),proc_ind(2),proc_ind(3) proc_count=proc_count+1 - if (proc_count>slice_npmax)then + if (proc_count>slice_npmax) then write(*,'(/,a)')'ERROR: number of processors per slice exceeds the maximum number!' stop endif @@ -156,12 +156,12 @@ subroutine read_input (inp_fname) endif ! read server information - if (output_stat==0 .and. out_format==1 .and. out_nslice>1)then - if (trim(token)=='server:')then + if (output_stat==0 .and. out_format==1 .and. out_nslice>1) then + if (trim(token)=='server:') then server_stat=-1 call split_string(tag,',',args,narg) slice_count2=slice_count2+1 - if (slice_count2>out_nslice)then + if (slice_count2>out_nslice) then write(*,'(/,a)')'ERROR: number of slices exceeds the actual number!' stop endif @@ -176,50 +176,50 @@ subroutine read_input (inp_fname) enddo ! do ! check for proclist: line number -if (slice_count11 .and. slice_count2>1 .and. slice_count21 .and. slice_count2>1 .and. slice_count21)then +if (out_format==1 .and. slice_count2==1 .and. out_nslice>1) then ! set server name and executable for all other server_name(2:out_nslice)=server_name(1) server_exec(2:out_nslice)=server_exec(1) endif ! check input status -if (input_stat /= 0)then +if (input_stat /= 0) then write(*,'(/,a)')'ERROR: error reading input information! make sure the line with "input:" token is correct.' stop endif ! check output status -if (output_stat /= 0)then +if (output_stat /= 0) then write(*,'(/,a)')'ERROR: error reading output information! make sure the line with "output:" token is correct.' stop endif ! check procinfo status -if (procinfo_stat /= 0)then +if (procinfo_stat /= 0) then write(*,'(/,a)')'ERROR: error reading processor information! make sure the line with "procinfo:" token is correct.' stop endif ! check proclist status -if (proclist_stat /= 0)then +if (proclist_stat /= 0) then write(*,'(/,a)')'ERROR: error reading processor list! make sure the line/s with "proclist:" token is/are correct.' stop endif ! check server status -if (out_format==1 .and. out_nslice>1 .and. server_stat /= 0)then +if (out_format==1 .and. out_nslice>1 .and. server_stat /= 0) then write(*,'(/,a)')'ERROR: error reading server information! make sure the line/s with "server:" token is/are correct.' stop endif diff --git a/utils/Visualization/Paraview/visualize_gold/src/string_process.f90 b/utils/Visualization/Paraview/visualize_gold/src/string_process.f90 index f46b05f9e..0d0ffb77c 100644 --- a/utils/Visualization/Paraview/visualize_gold/src/string_process.f90 +++ b/utils/Visualization/Paraview/visualize_gold/src/string_process.f90 @@ -54,7 +54,7 @@ subroutine first_token(str,token) ! first token is a word before first space do i=1,slen - if (tmp_str(i:i)==' ')then + if (tmp_str(i:i)==' ') then token=tmp_str(1:i-1) str=tmp_str(i+1:slen) exit @@ -82,7 +82,7 @@ subroutine first_char(str,ch,ind) ! find first character do i=1,slen - if (str(i:i)/=' ')then + if (str(i:i)/=' ') then ch=str(i:i) ind=i exit @@ -108,7 +108,7 @@ subroutine last_char(str,ch,ind) ! find last character do i=slen,1,-1 - if (str(i:i)/=' ')then + if (str(i:i)/=' ') then ch=str(i:i) ind=i exit @@ -136,7 +136,7 @@ subroutine split_string(str,delm,args,narg) ! find and count indices of all delimeters narg=0 do i=1,slen - if(tmp_str(i:i)==delm)then + if (tmp_str(i:i)==delm) then narg=narg+1 ind(narg)=i endif @@ -167,7 +167,7 @@ end subroutine split_string do i=1,nvar call split_string(slist(i),'=',args,narg) if (narg/=2)cycle - if (vname==trim(adjustl(args(1))))then + if (vname==trim(adjustl(args(1)))) then read(args(2),*)get_string return endif @@ -192,7 +192,7 @@ subroutine seek_string(vname,strval,slist,nvar) do i=1,nvar call split_string(slist(i),'=',args,narg) if (narg/=2)cycle - if (vname==trim(adjustl(args(1))))then + if (vname==trim(adjustl(args(1)))) then read(args(2),*)strval return endif @@ -219,7 +219,7 @@ function get_string_vect(vname,n,slist,nvar) do i=1,nvar call split_string(slist(i),'=',args,narg) if (narg/=2)cycle - if (vname==trim(adjustl(args(1))))then + if (vname==trim(adjustl(args(1)))) then read(args(2),*)get_string_vect return endif @@ -242,7 +242,7 @@ integer function get_integer(vname,slist,nvar) do i=1,nvar call split_string(slist(i),'=',args,narg) if (narg/=2)cycle - if (vname==trim(adjustl(args(1))))then + if (vname==trim(adjustl(args(1)))) then read(args(2),*)get_integer return endif @@ -268,7 +268,7 @@ function get_integer_vect(vname,n,slist,nvar) do i=1,nvar call split_string(slist(i),'=',args,narg) if (narg/=2)cycle - if (vname==trim(adjustl(args(1))))then + if (vname==trim(adjustl(args(1)))) then read(args(2),*)get_integer_vect(1:n) return endif @@ -291,7 +291,7 @@ real function get_real(vname,slist,nvar) do i=1,nvar call split_string(slist(i),'=',args,narg) if (narg/=2)cycle - if (vname==trim(adjustl(args(1))))then + if (vname==trim(adjustl(args(1)))) then read(args(2),*)get_real return endif diff --git a/utils/Visualization/Paraview/visualize_gold/src/visualize.f90 b/utils/Visualization/Paraview/visualize_gold/src/visualize.f90 index 36b774d04..0393237f3 100644 --- a/utils/Visualization/Paraview/visualize_gold/src/visualize.f90 +++ b/utils/Visualization/Paraview/visualize_gold/src/visualize.f90 @@ -74,10 +74,10 @@ program visualize stop endif -if (out_ncomp > inp_ncomp)then +if (out_ncomp > inp_ncomp) then write(*,'(/,a)')'ERROR: number of components for output cannot be greater than for input!' stop -else if (out_ncomp>1 .and. out_ncomp /= inp_ncomp)then +else if (out_ncomp>1 .and. out_ncomp /= inp_ncomp) then write(*,'(/,a)')'ERROR: not supported components transformation!' stop endif @@ -148,10 +148,10 @@ program visualize enddo write(*,'(a)')'complete!' -if (out_format==0)then +if (out_format==0) then ! VTK files call write_vtu() -else if (out_format==1)then +else if (out_format==1) then ! Ensight Gold files call write_ensight() else diff --git a/utils/Visualization/Paraview/visualize_gold/src/visualize_collect.f90 b/utils/Visualization/Paraview/visualize_gold/src/visualize_collect.f90 index 70186ebda..73b516e2a 100644 --- a/utils/Visualization/Paraview/visualize_gold/src/visualize_collect.f90 +++ b/utils/Visualization/Paraview/visualize_gold/src/visualize_collect.f90 @@ -73,14 +73,14 @@ subroutine cvd_count_totals_ext_mesh(nproc,proc_list,proc_width,inp_dir,& read(27) NSPEC_AB read(27) NGLOB_AB ! gets ibool - if(out_res/=2) then + if (out_res/=2) then allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) read(27) ibool endif close(27) ! calculates totals - if(out_res==2) then + if (out_res==2) then ! total number of global points node_count = node_count + NGLOB_AB @@ -90,7 +90,7 @@ subroutine cvd_count_totals_ext_mesh(nproc,proc_list,proc_width,inp_dir,& nelement = NSPEC_AB * (NGLLX-1) * (NGLLY-1) * (NGLLZ-1) elmt_count = elmt_count + nelement - else if (out_res==1)then ! Medium resolution + else if (out_res==1) then ! Medium resolution ! mark element corners (global AVS or DX points) allocate(mask_ibool(NGLOB_AB)) @@ -156,7 +156,7 @@ subroutine cvd_count_totals_ext_mesh(nproc,proc_list,proc_width,inp_dir,& ! total number of spectral elements elmt_count = elmt_count + NSPEC_AB deallocate(mask_ibool) - else if (out_res==0)then ! + else if (out_res==0) then ! ! mark element corners (global AVS or DX points) allocate(mask_ibool(NGLOB_AB)) mask_ibool = .false. @@ -191,7 +191,7 @@ subroutine cvd_count_totals_ext_mesh(nproc,proc_list,proc_width,inp_dir,& write(*,'(/,a)')'ERROR: wrong out_res value!' stop endif ! out_res - if(out_res/=2) then + if (out_res/=2) then deallocate(ibool) endif @@ -238,7 +238,7 @@ subroutine cvd_write_corners_only(NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore,& iglob(8)=ibool(1,NGLLY,NGLLZ,i_spec) do i_node=1,NENOD_OUT - if(.not. mask_ibool(iglob(i_node))) then + if (.not. mask_ibool(iglob(i_node))) then numpoin = numpoin + 1 x = xstore(iglob(i_node)) y = ystore(iglob(i_node)) @@ -313,7 +313,7 @@ subroutine cvd_write_hexa20_only(NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore,& iglob(20)=ibool(1,NGLLY,NGLLZ_MID,i_spec) do i_node=1,NENOD_OUT - if(.not. mask_ibool(iglob(i_node))) then + if (.not. mask_ibool(iglob(i_node))) then numpoin = numpoin + 1 x = xstore(iglob(i_node)) y = ystore(iglob(i_node)) @@ -361,7 +361,7 @@ subroutine cvd_write_GLL_points_only(NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstor do j = 1, NGLLY do i = 1, NGLLX iglob1 = ibool(i,j,k,i_spec) - if(.not. mask_ibool(iglob1)) then + if (.not. mask_ibool(iglob1)) then numpoin = numpoin + 1 x = xstore(iglob1) y = ystore(iglob1) @@ -426,7 +426,7 @@ subroutine cvd_write_corners_data(NSPEC_AB,NGLOB_AB,ibool,dat,& tmp_dat(8)=dat(1,NGLLY,NGLLZ,i_spec) do i_node=1,NENOD_OUT - if(.not. mask_ibool(iglob(i_node))) then + if (.not. mask_ibool(iglob(i_node))) then numpoin = numpoin + 1 call write_real(tmp_dat(i_node),fd) mask_ibool(iglob(i_node)) = .true. @@ -474,7 +474,7 @@ subroutine cvd_write_corners_data_glob(NSPEC_AB,NGLOB_AB,ibool,dat,& iglob(8)=ibool(1,NGLLY,NGLLZ,i_spec) do i_node=1,NENOD_OUT - if(.not. mask_ibool(iglob(i_node))) then + if (.not. mask_ibool(iglob(i_node))) then numpoin = numpoin + 1 call write_real(dat(iglob(i_node)),fd) mask_ibool(iglob(i_node)) = .true. @@ -575,7 +575,7 @@ subroutine cvd_write_hexa20_data(NSPEC_AB,NGLOB_AB,ibool,dat,& tmp_dat(20)=dat(1,NGLLY,NGLLZ_MID,i_spec) do i_node=1,NENOD_OUT - if(.not. mask_ibool(iglob(i_node))) then + if (.not. mask_ibool(iglob(i_node))) then numpoin = numpoin + 1 call write_real(tmp_dat(i_node),fd) mask_ibool(iglob(i_node)) = .true. @@ -644,7 +644,7 @@ subroutine cvd_write_hexa20_data_glob(NSPEC_AB,NGLOB_AB,ibool,dat,& iglob(20)=ibool(1,NGLLY,NGLLZ_MID,i_spec) do i_node=1,NENOD_OUT - if(.not. mask_ibool(iglob(i_node))) then + if (.not. mask_ibool(iglob(i_node))) then numpoin = numpoin + 1 call write_real(dat(iglob(i_node)),fd) mask_ibool(iglob(i_node)) = .true. @@ -685,7 +685,7 @@ subroutine cvd_write_GLL_points_data(NSPEC_AB,NGLOB_AB,ibool,dat,& do j = 1, NGLLY do i = 1, NGLLX iglob1 = ibool(i,j,k,i_spec) - if(.not. mask_ibool(iglob1)) then + if (.not. mask_ibool(iglob1)) then numpoin = numpoin + 1 call write_real(dat(i,j,k,i_spec),fd) mask_ibool(iglob1) = .true. @@ -727,7 +727,7 @@ subroutine cvd_write_GLL_points_data_glob(NSPEC_AB,NGLOB_AB,ibool,dat,& do j = 1, NGLLY do i = 1, NGLLX iglob1 = ibool(i,j,k,i_spec) - if(.not. mask_ibool(iglob1)) then + if (.not. mask_ibool(iglob1)) then numpoin = numpoin + 1 call write_real(dat(iglob1),fd) mask_ibool(iglob1) = .true. @@ -780,7 +780,7 @@ subroutine cvd_write_corner_elements(NSPEC_AB,NGLOB_AB,ibool,& ! sets increasing numbering do i_node=1,NENOD_OUT - if(.not. mask_ibool(iglob(i_node))) then + if (.not. mask_ibool(iglob(i_node))) then numpoin = numpoin + 1 num_ibool(iglob(i_node)) = numpoin mask_ibool(iglob(i_node)) = .true. @@ -861,7 +861,7 @@ subroutine cvd_write_hexa20_elements(NSPEC_AB,NGLOB_AB,ibool,& ! sets increasing numbering do i_node=1,NENOD_OUT - if(.not. mask_ibool(iglob(i_node))) then + if (.not. mask_ibool(iglob(i_node))) then numpoin = numpoin + 1 num_ibool(iglob(i_node)) = numpoin mask_ibool(iglob(i_node)) = .true. @@ -916,7 +916,7 @@ subroutine cvd_write_GLL_elements(NSPEC_AB,NGLOB_AB,ibool, & do j = 1, NGLLY do i = 1, NGLLX iglob1 = ibool(i,j,k,i_spec) - if(.not. mask_ibool(iglob1)) then + if (.not. mask_ibool(iglob1)) then numpoin = numpoin + 1 num_ibool(iglob1) = numpoin mask_ibool(iglob1) = .true. @@ -1011,7 +1011,7 @@ subroutine cvd_write_corners(NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore,dat,& tmp_dat(8)=dat(1,NGLLY,NGLLZ,i_spec) do i_node=1,NENOD_OUT - if(.not. mask_ibool(iglob(i_node))) then + if (.not. mask_ibool(iglob(i_node))) then numpoin = numpoin + 1 x = xstore(iglob(i_node)) y = ystore(iglob(i_node)) @@ -1064,7 +1064,7 @@ subroutine cvd_write_GLL_points(NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore,dat do j = 1, NGLLY do i = 1, NGLLX iglob1 = ibool(i,j,k,i_spec) - if(.not. mask_ibool(iglob1)) then + if (.not. mask_ibool(iglob1)) then numpoin = numpoin + 1 x = xstore(iglob1) y = ystore(iglob1) diff --git a/utils/Visualization/Paraview/visualize_gold/src/write_ensight.f90 b/utils/Visualization/Paraview/visualize_gold/src/write_ensight.f90 index d654a2af8..8636403ab 100644 --- a/utils/Visualization/Paraview/visualize_gold/src/write_ensight.f90 +++ b/utils/Visualization/Paraview/visualize_gold/src/write_ensight.f90 @@ -33,7 +33,7 @@ subroutine write_ensight () !character(len=80),dimension(out_nslice),optional :: server_name, server_exec ! Write a Ensight Gold SOS file -if (out_nslice>1)then +if (out_nslice>1) then open(unit=101, file=trim(out_path)// '/' // trim(out_head)//'.sos', status='replace', action='write', iostat=ios) write(101,'(a)')'FORMAT' @@ -111,7 +111,7 @@ subroutine write_ensight_serial (i_slice,nproc,proc_list) integer :: nnode,nelmt ! Ensight element type -if (out_res==1)then +if (out_res==1) then ! Medium resolution ! 20-noded hexahedra ensight_etype='hexa20' @@ -129,7 +129,7 @@ subroutine write_ensight_serial (i_slice,nproc,proc_list) !write(*,'(a)',advance='no')'writing Ensight case file...' open(unit=11, file=trim(out_path)// '/' // trim(file_head)//'.case', status='replace', action='write', iostat=ios) -if (ios /= 0)then +if (ios /= 0) then write(*,'(/,a)')'ERROR: output file "'//trim(file_head)//'.case'//'" cannot be opened!' stop endif @@ -141,11 +141,11 @@ subroutine write_ensight_serial (i_slice,nproc,proc_list) write(11,'(a,a,/)')'model: ',trim(file_head)//'.geo' write(11,'(a)')'VARIABLE' -if (out_ncomp == 1)then +if (out_ncomp == 1) then write(11,'(a,i10,a,a,a,a,/)')'scalar per node: ',ts,' ',trim(out_vname),' ',trim(file_head)//'_'//wild_char(1:t_width)//'.scl' -else if (out_ncomp == 3)then +else if (out_ncomp == 3) then write(11,'(a,i10,a,a,a,a,/)')'vector per node: ',ts,' ',trim(out_vname),' ',trim(file_head)//'_'//wild_char(1:t_width)//'.vec' -else if (out_ncomp == 6)then +else if (out_ncomp == 6) then write(11,'(a,i10,a,a,a,a,/)')'tensor symm per node: ',ts,' ',trim(out_vname),' ', & trim(file_head)//wild_char(1:t_width)//'.tns' else @@ -245,15 +245,15 @@ subroutine write_ensight_serial (i_slice,nproc,proc_list) close(27) ! writes point coordinates and scalar value to mesh file - if (out_res==0)then + if (out_res==0) then ! writes out element corners only call cvd_write_corners_only(NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore, & nnode,fd_x,fd_y,fd_z) - else if (out_res==1)then + else if (out_res==1) then ! writes out element corners only call cvd_write_hexa20_only(NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore, & nnode,fd_x,fd_y,fd_z) - else if (out_res==2)then + else if (out_res==2) then ! high resolution, all GLL points call cvd_write_GLL_points_only(NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore,& nnode,fd_x,fd_y,fd_z) @@ -275,7 +275,7 @@ subroutine write_ensight_serial (i_slice,nproc,proc_list) call close_file(fd_y) call close_file(fd_z) -if (node_count /= slice_nnode(i_slice))then +if (node_count /= slice_nnode(i_slice)) then write(*,'(/,a)')'Error: number of total points are not consistent!' stop endif @@ -343,7 +343,7 @@ subroutine write_ensight_serial (i_slice,nproc,proc_list) ! spectral elements call cvd_write_hexa20_elements(NSPEC_AB,NGLOB_AB,ibool, & node_count,nelmt,nnode,fd) - else if (out_res==2)then + else if (out_res==2) then ! subdivided spectral elements call cvd_write_GLL_elements(NSPEC_AB,NGLOB_AB,ibool, & node_count,nelmt,nnode,fd) @@ -432,7 +432,7 @@ subroutine write_ensight_serial (i_slice,nproc,proc_list) allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) read(27) ibool close(27) - if (dat_topo == 0)then + if (dat_topo == 0) then allocate(dat(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) ! data file @@ -463,7 +463,7 @@ subroutine write_ensight_serial (i_slice,nproc,proc_list) endif ! cleans up memory allocations deallocate(dat) - else if (dat_topo==1)then + else if (dat_topo==1) then allocate(dat_glob(NGLOB_AB)) ! data file @@ -503,7 +503,7 @@ subroutine write_ensight_serial (i_slice,nproc,proc_list) node_count = node_count + nnode enddo ! i_proc = 1, nproc - if (node_count /= slice_nnode(i_slice))then + if (node_count /= slice_nnode(i_slice)) then write(*,'(/,a)')'Error: Number of total points are not consistent' stop endif @@ -524,7 +524,7 @@ subroutine write_ensight_serial (i_slice,nproc,proc_list) read(27) ibool close(27) - if (dat_topo==0)then + if (dat_topo==0) then allocate(tmp_dat(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) allocate(dat(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) tmp_dat=0.0 @@ -544,7 +544,7 @@ subroutine write_ensight_serial (i_slice,nproc,proc_list) tmp_dat=tmp_dat+real(dat) !write(*,*)inp_fname enddo - if (inp_ncomp==3 .and. out_ncomp==1)then + if (inp_ncomp==3 .and. out_ncomp==1) then tmp_dat=0.5*tmp_dat ! Equivalent to S-wave potential endif @@ -564,7 +564,7 @@ subroutine write_ensight_serial (i_slice,nproc,proc_list) endif ! cleans up memory allocations deallocate(ibool,dat,tmp_dat) - else if (dat_topo==1)then + else if (dat_topo==1) then allocate(tmp_dat_glob(NGLOB_AB)) allocate(dat_glob(NGLOB_AB)) tmp_dat=0.0 @@ -583,7 +583,7 @@ subroutine write_ensight_serial (i_slice,nproc,proc_list) tmp_dat_glob=tmp_dat_glob+real(dat_glob) !write(*,*)inp_fname enddo - if (inp_ncomp==3 .and. out_ncomp==1)then + if (inp_ncomp==3 .and. out_ncomp==1) then tmp_dat_glob=0.5*tmp_dat_glob ! Equivalent to S-wave potential endif diff --git a/utils/Visualization/Paraview/visualize_gold/src/write_vtu.f90 b/utils/Visualization/Paraview/visualize_gold/src/write_vtu.f90 index 3921b6c3d..b8e3fb8db 100644 --- a/utils/Visualization/Paraview/visualize_gold/src/write_vtu.f90 +++ b/utils/Visualization/Paraview/visualize_gold/src/write_vtu.f90 @@ -49,9 +49,9 @@ subroutine write_vtu write(*,'(a)')'writing VTK files...' ! Determine the Endianness of the Architecture call get_endian(endian) -if(endian == LE)then +if (endian == LE) then byte_order='LittleEndian' -else if(endian == BE)then +else if (endian == BE) then byte_order='BigEndian' else write(*,'(/,a)')'ERROR: illegal endianness!' @@ -59,7 +59,7 @@ subroutine write_vtu endif ! vtk element type -if (out_res==1)then +if (out_res==1) then ! Medium resolution ! 20-noded hexahedra vtk_etype=25 @@ -88,7 +88,7 @@ subroutine write_vtu ! Open pvd file pvd_file=trim(out_path)//'/'// trim(out_head)//'.pvd' open(unit=pvd_unit, file=trim(pvd_file), status='replace', action='write', iostat=ios) -if (ios /= 0)then +if (ios /= 0) then write(*,'(/,a)')'ERROR: output file "'//trim(pvd_file)//'" cannot be opened!' stop endif @@ -184,7 +184,7 @@ subroutine write_vtu off(1)=0; ! 1st offset do i=1,plot_nvar - if(i < plot_nvar)then + if (i < plot_nvar) then off(i+1)=off(i)+size_int+bytes(i) endif bytes(i)=bytes(i)+size_int @@ -203,7 +203,7 @@ subroutine write_vtu vtu_file = trim(out_path) // '/' // trim(out_fname) open(unit=vtu_unit, file=trim(vtu_file), action='write', status='replace',iostat=ios) !write(*,*)trim(vtu_file),vtu_unit - if (ios/=0)then + if (ios/=0) then write(*,'(/,a)')'ERROR: file '//trim(vtu_file)//' cannot be opened!' stop endif @@ -260,7 +260,7 @@ subroutine write_vtu write(vtu_unit,'(a)',advance='no')trim(buffer) close(vtu_unit) - if (i_t==1)then + if (i_t==1) then ! open temporary files to store coordinates write(tmp_str,*)i_slice call open_file2write('../tmp/tmp_x_slice'//trim(adjustl(tmp_str))//char(0),fd_x) @@ -303,11 +303,11 @@ subroutine write_vtu ! writes out element corners only call cvd_write_corners_only(NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore, & nnode,fd_x,fd_y,fd_z) - else if (out_res==1)then + else if (out_res==1) then ! writes out element corners only call cvd_write_hexa20_only(NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore, & nnode,fd_x,fd_y,fd_z) - else if(out_res==2)then + else if (out_res==2) then ! high resolution, all GLL points call cvd_write_GLL_points_only(NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore,& nnode,fd_x,fd_y,fd_z) @@ -327,7 +327,7 @@ subroutine write_vtu ! Read and store connectivity list ! writes out element corner indices - if(out_res==0) then + if (out_res==0) then ! spectral elements call cvd_write_corner_elements(NSPEC_AB,NGLOB_AB,ibool, & node_count,nelmt,nnode,fd_con) @@ -335,7 +335,7 @@ subroutine write_vtu ! spectral elements call cvd_write_hexa20_elements(NSPEC_AB,NGLOB_AB,ibool, & node_count,nelmt,nnode,fd_con) - else if(out_res==2)then + else if (out_res==2) then ! subdivided spectral elements call cvd_write_GLL_elements(NSPEC_AB,NGLOB_AB,ibool, & node_count,nelmt,nnode,fd_con) @@ -348,7 +348,7 @@ subroutine write_vtu !write(*,*)' elements:',elmt_count,nelmt !write(*,*)' points : ',node_count,nnode !write(*,*)tmp_nnode,node_count - if (tmp_nnode/=node_count)then + if (tmp_nnode/=node_count) then write(*,'(/,a)')'ERROR: inconsistent number of nodes!' stop endif @@ -421,8 +421,8 @@ subroutine write_vtu ! write data to vtu file call write_integer(bytes(5),fd) - if (out_ncomp>1)then ! vector or tensor data - if (i_t==1)then + if (out_ncomp>1) then ! vector or tensor data + if (i_t==1) then allocate(fd_array(out_ncomp)) allocate(tmp_rvect(out_ncomp)) endif @@ -450,7 +450,7 @@ subroutine write_vtu read(27) ibool close(27) - if (dat_topo==0)then ! Data from local points + if (dat_topo==0) then ! Data from local points allocate(dat(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) do i_comp=1,inp_ncomp @@ -486,7 +486,7 @@ subroutine write_vtu ! cleans up memory allocations deallocate(dat) - else if (dat_topo==1)then ! Data from global points + else if (dat_topo==1) then ! Data from global points allocate(dat_glob(NGLOB_AB)) do i_comp=1,inp_ncomp @@ -530,7 +530,7 @@ subroutine write_vtu node_count = node_count + nnode enddo ! i_proc = 1, nproc - if (node_count /= slice_nnode(i_slice))then + if (node_count /= slice_nnode(i_slice)) then write(*,'(/,a)')'Error: Number of total points are not consistent' stop endif @@ -545,7 +545,7 @@ subroutine write_vtu write(tmp_str,*)i_comp call open_file2read('../tmp/tmp_data_comp'//trim(adjustl(tmp_str))//char(0),fd_array(i_comp)) enddo - if (out_ncomp==3)then + if (out_ncomp==3) then ! vector do i=1,slice_nnode(i_slice) do i_comp=1,out_ncomp @@ -553,7 +553,7 @@ subroutine write_vtu call write_float(tmp_real,fd) enddo enddo - else if (out_ncomp==6)then + else if (out_ncomp==6) then ! 9-component symmetric tensor do i=1,slice_nnode(i_slice) do i_comp=1,out_ncomp @@ -592,7 +592,7 @@ subroutine write_vtu read(27) ibool close(27) - if (dat_topo==0)then ! Data from local points + if (dat_topo==0) then ! Data from local points allocate(tmp_dat(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) allocate(dat(NGLLX,NGLLY,NGLLZ,NSPEC_AB)) tmp_dat=0.0 @@ -612,7 +612,7 @@ subroutine write_vtu tmp_dat=tmp_dat+real(dat) !write(*,*)inp_fname enddo - if (inp_ncomp==3 .and. out_ncomp==1)then + if (inp_ncomp==3 .and. out_ncomp==1) then tmp_dat=0.5*tmp_dat ! Equivalent to S-wave potential endif @@ -632,7 +632,7 @@ subroutine write_vtu endif ! cleans up memory allocations deallocate(ibool,dat,tmp_dat) - else if (dat_topo==1)then ! Data from global points + else if (dat_topo==1) then ! Data from global points allocate(tmp_dat_glob(NGLOB_AB)) allocate(dat_glob(NGLOB_AB)) tmp_dat=0.0 @@ -651,7 +651,7 @@ subroutine write_vtu tmp_dat_glob=tmp_dat_glob+real(dat_glob) !write(*,*)inp_fname enddo - if (inp_ncomp==3 .and. out_ncomp==1)then + if (inp_ncomp==3 .and. out_ncomp==1) then tmp_dat_glob=0.5*tmp_dat_glob ! Equivalent to S-wave potential endif @@ -680,7 +680,7 @@ subroutine write_vtu enddo ! i_proc = 1, nproc call close_file(fd) - if (node_count /= slice_nnode(i_slice))then + if (node_count /= slice_nnode(i_slice)) then write(*,'(/,a)')'Error: Number of total points are not consistent' stop endif @@ -728,7 +728,7 @@ subroutine write_vtu call delete_file('../tmp/tmp_con_slice'//trim(adjustl(tmp_str))//char(0)) enddo -if (out_ncomp>1)then +if (out_ncomp>1) then ! free memory deallocate(fd_array,tmp_rvect) ! delete temporary data files diff --git a/utils/Visualization/opendx_AVS/convert_CUBIT_SPECFEM_mesh_to_OpenDX.f90 b/utils/Visualization/opendx_AVS/convert_CUBIT_SPECFEM_mesh_to_OpenDX.f90 index 869390268..af715bcfc 100644 --- a/utils/Visualization/opendx_AVS/convert_CUBIT_SPECFEM_mesh_to_OpenDX.f90 +++ b/utils/Visualization/opendx_AVS/convert_CUBIT_SPECFEM_mesh_to_OpenDX.f90 @@ -29,7 +29,7 @@ program convert_CUBIT_SPECFEM_to_DX print *,' 2 = use CPML flag file to color the mesh elements' print *,' 3 = exit' read(*,*) iflag - if(iflag /= 1 .and. iflag /= 2) stop 'exiting...' + if (iflag /= 1 .and. iflag /= 2) stop 'exiting...' print * ! open SPECFEM3D_Cartesian mesh file to read the points @@ -96,7 +96,7 @@ program convert_CUBIT_SPECFEM_to_DX write(11,*) 'object 3 class array type float rank 0 items ',nspec,' data follows' ! read local elements in this slice and output global DX elements - if(iflag == 1) then + if (iflag == 1) then open(unit=23,file='materials_file',status='old',action='read') do ispec=1,nspec ! beware: elements may not be listed in increasing order, they can appear in any order @@ -108,7 +108,7 @@ program convert_CUBIT_SPECFEM_to_DX imat(:) = 0 open(unit=23,file='absorbing_cpml_file',status='old',action='read') read(23,*) nspec_CPML - if(nspec_CPML < 1 .or. nspec_CPML > nspec) stop 'incorrect value of nspec_CPML read' + if (nspec_CPML < 1 .or. nspec_CPML > nspec) stop 'incorrect value of nspec_CPML read' do ispec=1,nspec_CPML ! beware: elements may not be listed in increasing order, they can appear in any order read(23,*) ispec_read,imat_read diff --git a/utils/Visualization/opendx_AVS/convert_coastline_dx.f90 b/utils/Visualization/opendx_AVS/convert_coastline_dx.f90 index b392468d2..57336e719 100644 --- a/utils/Visualization/opendx_AVS/convert_coastline_dx.f90 +++ b/utils/Visualization/opendx_AVS/convert_coastline_dx.f90 @@ -32,11 +32,11 @@ program jdjfdf do ielem=1,nelem ! locate point in list do ipoin = 1,npoin -if(i1(ielem) == ibool(ipoin)) goto 700 +if (i1(ielem) == ibool(ipoin)) goto 700 enddo 700 i1val = ipoin do ipoin = 1,npoin -if(i2(ielem) == ibool(ipoin)) goto 710 +if (i2(ielem) == ibool(ipoin)) goto 710 enddo 710 i2val = ipoin ! DK DK point number start at 0 in OpenDX diff --git a/utils/Visualization/opendx_AVS/resample_CA_coastline_AVS.f90 b/utils/Visualization/opendx_AVS/resample_CA_coastline_AVS.f90 index fbde54c04..f7f489ce1 100644 --- a/utils/Visualization/opendx_AVS/resample_CA_coastline_AVS.f90 +++ b/utils/Visualization/opendx_AVS/resample_CA_coastline_AVS.f90 @@ -33,10 +33,10 @@ program dfdfd read(5,*) x(ipoin),y(ipoin) xval = x(ipoin) yval = y(ipoin) - if(xval < xmin) xval = xmin - if(xval > xmax) xval = xmax - if(yval < ymin) yval = ymin - if(yval > ymax) yval = ymax + if (xval < xmin) xval = xmin + if (xval > xmax) xval = xmax + if (yval < ymin) yval = ymin + if (yval > ymax) yval = ymax x(ipoin) = xval y(ipoin) = yval enddo @@ -60,20 +60,20 @@ program dfdfd ! exclude elements that are outside of clipping box, or wrong data value nelemnew = 0 do ielem=1,nelem - if(x(i1(ielem)) < xmin .or. x(i1(ielem)) > xmax .or. y(i1(ielem)) < ymin .or. y(i1(ielem)) > ymax) then + if (x(i1(ielem)) < xmin .or. x(i1(ielem)) > xmax .or. y(i1(ielem)) < ymin .or. y(i1(ielem)) > ymax) then p1outside = .true. else p1outside = .false. endif - if(x(i2(ielem)) < xmin .or. x(i2(ielem)) > xmax .or. y(i2(ielem)) < ymin .or. y(i2(ielem)) > ymax) then + if (x(i2(ielem)) < xmin .or. x(i2(ielem)) > xmax .or. y(i2(ielem)) < ymin .or. y(i2(ielem)) > ymax) then p2outside = .true. else p2outside = .false. endif !!! DK DK coastline only, no faults - if(.not. p1outside .and. .not. p2outside .and. dataval(ielem) > 254.) nelemnew = nelemnew + 1 + if (.not. p1outside .and. .not. p2outside .and. dataval(ielem) > 254.) nelemnew = nelemnew + 1 enddo ! write points @@ -87,20 +87,20 @@ program dfdfd ! exclude elements that are outside of clipping box, or wrong data value ielemreal = 0 do ielem=1,nelem - if(x(i1(ielem)) < xmin .or. x(i1(ielem)) > xmax .or. y(i1(ielem)) < ymin .or. y(i1(ielem)) > ymax) then + if (x(i1(ielem)) < xmin .or. x(i1(ielem)) > xmax .or. y(i1(ielem)) < ymin .or. y(i1(ielem)) > ymax) then p1outside = .true. else p1outside = .false. endif - if(x(i2(ielem)) < xmin .or. x(i2(ielem)) > xmax .or. y(i2(ielem)) < ymin .or. y(i2(ielem)) > ymax) then + if (x(i2(ielem)) < xmin .or. x(i2(ielem)) > xmax .or. y(i2(ielem)) < ymin .or. y(i2(ielem)) > ymax) then p2outside = .true. else p2outside = .false. endif !!! DK DK coastline only, no faults - if(.not. p1outside .and. .not. p2outside .and. dataval(ielem) > 254.) then + if (.not. p1outside .and. .not. p2outside .and. dataval(ielem) > 254.) then ielemreal = ielemreal + 1 write(*,*) ielemreal,' 1 line ',i1(ielem)+1,i2(ielem)+1 endif @@ -114,20 +114,20 @@ program dfdfd ! exclude elements that are outside of clipping box, or wrong data value ielemreal = 0 do ielem=1,nelem - if(x(i1(ielem)) < xmin .or. x(i1(ielem)) > xmax .or. y(i1(ielem)) < ymin .or. y(i1(ielem)) > ymax) then + if (x(i1(ielem)) < xmin .or. x(i1(ielem)) > xmax .or. y(i1(ielem)) < ymin .or. y(i1(ielem)) > ymax) then p1outside = .true. else p1outside = .false. endif - if(x(i2(ielem)) < xmin .or. x(i2(ielem)) > xmax .or. y(i2(ielem)) < ymin .or. y(i2(ielem)) > ymax) then + if (x(i2(ielem)) < xmin .or. x(i2(ielem)) > xmax .or. y(i2(ielem)) < ymin .or. y(i2(ielem)) > ymax) then p2outside = .true. else p2outside = .false. endif !!! DK DK coastline only, no faults - if(.not. p1outside .and. .not. p2outside .and. dataval(ielem) > 254.) then + if (.not. p1outside .and. .not. p2outside .and. dataval(ielem) > 254.) then ielemreal = ielemreal + 1 write(*,*) dataval(ielem) endif diff --git a/utils/Visualization/opendx_AVS/resample_CA_highways_AVS.f90 b/utils/Visualization/opendx_AVS/resample_CA_highways_AVS.f90 index f95391465..043dff7a4 100644 --- a/utils/Visualization/opendx_AVS/resample_CA_highways_AVS.f90 +++ b/utils/Visualization/opendx_AVS/resample_CA_highways_AVS.f90 @@ -33,10 +33,10 @@ program dfdfd read(5,*) x(ipoin),y(ipoin) xval = x(ipoin) yval = y(ipoin) - if(xval < xmin) xval = xmin - if(xval > xmax) xval = xmax - if(yval < ymin) yval = ymin - if(yval > ymax) yval = ymax + if (xval < xmin) xval = xmin + if (xval > xmax) xval = xmax + if (yval < ymin) yval = ymin + if (yval > ymax) yval = ymax x(ipoin) = xval y(ipoin) = yval enddo @@ -60,19 +60,19 @@ program dfdfd ! exclude elements that are outside of clipping box, or wrong data value nelemnew = 0 do ielem=1,nelem - if(x(i1(ielem)) < xmin .or. x(i1(ielem)) > xmax .or. y(i1(ielem)) < ymin .or. y(i1(ielem)) > ymax) then + if (x(i1(ielem)) < xmin .or. x(i1(ielem)) > xmax .or. y(i1(ielem)) < ymin .or. y(i1(ielem)) > ymax) then p1outside = .true. else p1outside = .false. endif - if(x(i2(ielem)) < xmin .or. x(i2(ielem)) > xmax .or. y(i2(ielem)) < ymin .or. y(i2(ielem)) > ymax) then + if (x(i2(ielem)) < xmin .or. x(i2(ielem)) > xmax .or. y(i2(ielem)) < ymin .or. y(i2(ielem)) > ymax) then p2outside = .true. else p2outside = .false. endif - if(.not. p1outside .and. .not. p2outside .and. (dataval(ielem) < 0.1 .or. dataval(ielem) > 254.5)) nelemnew = nelemnew + 1 + if (.not. p1outside .and. .not. p2outside .and. (dataval(ielem) < 0.1 .or. dataval(ielem) > 254.5)) nelemnew = nelemnew + 1 enddo ! write points @@ -86,19 +86,19 @@ program dfdfd ! exclude elements that are outside of clipping box, or wrong data value ielemreal = 0 do ielem=1,nelem - if(x(i1(ielem)) < xmin .or. x(i1(ielem)) > xmax .or. y(i1(ielem)) < ymin .or. y(i1(ielem)) > ymax) then + if (x(i1(ielem)) < xmin .or. x(i1(ielem)) > xmax .or. y(i1(ielem)) < ymin .or. y(i1(ielem)) > ymax) then p1outside = .true. else p1outside = .false. endif - if(x(i2(ielem)) < xmin .or. x(i2(ielem)) > xmax .or. y(i2(ielem)) < ymin .or. y(i2(ielem)) > ymax) then + if (x(i2(ielem)) < xmin .or. x(i2(ielem)) > xmax .or. y(i2(ielem)) < ymin .or. y(i2(ielem)) > ymax) then p2outside = .true. else p2outside = .false. endif - if(.not. p1outside .and. .not. p2outside .and. (dataval(ielem) < 0.1 .or. dataval(ielem) > 254.5)) then + if (.not. p1outside .and. .not. p2outside .and. (dataval(ielem) < 0.1 .or. dataval(ielem) > 254.5)) then ielemreal = ielemreal + 1 write(*,*) ielemreal,' 1 line ',i1(ielem)+1,i2(ielem)+1 endif @@ -112,19 +112,19 @@ program dfdfd ! exclude elements that are outside of clipping box, or wrong data value ielemreal = 0 do ielem=1,nelem - if(x(i1(ielem)) < xmin .or. x(i1(ielem)) > xmax .or. y(i1(ielem)) < ymin .or. y(i1(ielem)) > ymax) then + if (x(i1(ielem)) < xmin .or. x(i1(ielem)) > xmax .or. y(i1(ielem)) < ymin .or. y(i1(ielem)) > ymax) then p1outside = .true. else p1outside = .false. endif - if(x(i2(ielem)) < xmin .or. x(i2(ielem)) > xmax .or. y(i2(ielem)) < ymin .or. y(i2(ielem)) > ymax) then + if (x(i2(ielem)) < xmin .or. x(i2(ielem)) > xmax .or. y(i2(ielem)) < ymin .or. y(i2(ielem)) > ymax) then p2outside = .true. else p2outside = .false. endif - if(.not. p1outside .and. .not. p2outside .and. (dataval(ielem) < 0.1 .or. dataval(ielem) > 254.5)) then + if (.not. p1outside .and. .not. p2outside .and. (dataval(ielem) < 0.1 .or. dataval(ielem) > 254.5)) then ielemreal = ielemreal + 1 write(*,*) dataval(ielem) endif diff --git a/utils/Visualization/opendx_AVS/resample_CA_highways_DX.f90 b/utils/Visualization/opendx_AVS/resample_CA_highways_DX.f90 index 09b6c535f..5c11251ec 100644 --- a/utils/Visualization/opendx_AVS/resample_CA_highways_DX.f90 +++ b/utils/Visualization/opendx_AVS/resample_CA_highways_DX.f90 @@ -34,10 +34,10 @@ program dfdfd read(5,*) x(ipoin),y(ipoin) xval = x(ipoin) yval = y(ipoin) - if(xval < xmin) xval = xmin - if(xval > xmax) xval = xmax - if(yval < ymin) yval = ymin - if(yval > ymax) yval = ymax + if (xval < xmin) xval = xmin + if (xval > xmax) xval = xmax + if (yval < ymin) yval = ymin + if (yval > ymax) yval = ymax write(*,*) xval,yval,izval enddo @@ -60,19 +60,19 @@ program dfdfd ! exclude elements that are outside of clipping box, or wrong data value nelemnew = 0 do ielem=1,nelem - if(x(i1(ielem)) < xmin .or. x(i1(ielem)) > xmax .or. y(i1(ielem)) < ymin .or. y(i1(ielem)) > ymax) then + if (x(i1(ielem)) < xmin .or. x(i1(ielem)) > xmax .or. y(i1(ielem)) < ymin .or. y(i1(ielem)) > ymax) then p1outside = .true. else p1outside = .false. endif - if(x(i2(ielem)) < xmin .or. x(i2(ielem)) > xmax .or. y(i2(ielem)) < ymin .or. y(i2(ielem)) > ymax) then + if (x(i2(ielem)) < xmin .or. x(i2(ielem)) > xmax .or. y(i2(ielem)) < ymin .or. y(i2(ielem)) > ymax) then p2outside = .true. else p2outside = .false. endif - if(.not. p1outside .and. .not. p2outside .and. (dataval(ielem) < 0.1 .or. dataval(ielem) > 254.5)) nelemnew = nelemnew + 1 + if (.not. p1outside .and. .not. p2outside .and. (dataval(ielem) < 0.1 .or. dataval(ielem) > 254.5)) nelemnew = nelemnew + 1 enddo write(*,*) 'object 2 class array type int rank 1 shape 2 items ',nelemnew,' data follows' @@ -80,19 +80,19 @@ program dfdfd ! then write elements kept ! exclude elements that are outside of clipping box, or wrong data value do ielem=1,nelem - if(x(i1(ielem)) < xmin .or. x(i1(ielem)) > xmax .or. y(i1(ielem)) < ymin .or. y(i1(ielem)) > ymax) then + if (x(i1(ielem)) < xmin .or. x(i1(ielem)) > xmax .or. y(i1(ielem)) < ymin .or. y(i1(ielem)) > ymax) then p1outside = .true. else p1outside = .false. endif - if(x(i2(ielem)) < xmin .or. x(i2(ielem)) > xmax .or. y(i2(ielem)) < ymin .or. y(i2(ielem)) > ymax) then + if (x(i2(ielem)) < xmin .or. x(i2(ielem)) > xmax .or. y(i2(ielem)) < ymin .or. y(i2(ielem)) > ymax) then p2outside = .true. else p2outside = .false. endif - if(.not. p1outside .and. .not. p2outside .and. (dataval(ielem) < 0.1 .or. dataval(ielem) > 254.5)) & + if (.not. p1outside .and. .not. p2outside .and. (dataval(ielem) < 0.1 .or. dataval(ielem) > 254.5)) & write(*,*) i1(ielem),i2(ielem) enddo @@ -104,19 +104,19 @@ program dfdfd ! then write element data for elements kept ! exclude elements that are outside of clipping box, or wrong data value do ielem=1,nelem - if(x(i1(ielem)) < xmin .or. x(i1(ielem)) > xmax .or. y(i1(ielem)) < ymin .or. y(i1(ielem)) > ymax) then + if (x(i1(ielem)) < xmin .or. x(i1(ielem)) > xmax .or. y(i1(ielem)) < ymin .or. y(i1(ielem)) > ymax) then p1outside = .true. else p1outside = .false. endif - if(x(i2(ielem)) < xmin .or. x(i2(ielem)) > xmax .or. y(i2(ielem)) < ymin .or. y(i2(ielem)) > ymax) then + if (x(i2(ielem)) < xmin .or. x(i2(ielem)) > xmax .or. y(i2(ielem)) < ymin .or. y(i2(ielem)) > ymax) then p2outside = .true. else p2outside = .false. endif - if(.not. p1outside .and. .not. p2outside .and. (dataval(ielem) < 0.1 .or. dataval(ielem) > 254.5)) & + if (.not. p1outside .and. .not. p2outside .and. (dataval(ielem) < 0.1 .or. dataval(ielem) > 254.5)) & write(*,*) dataval(ielem) enddo diff --git a/utils/adjoint_sources/SU_adjoint.f90 b/utils/adjoint_sources/SU_adjoint.f90 index 3d934860d..f0394f7db 100644 --- a/utils/adjoint_sources/SU_adjoint.f90 +++ b/utils/adjoint_sources/SU_adjoint.f90 @@ -84,7 +84,7 @@ program SU_adjoint filename = trim(DATA_PATH)//trim(adjustl(procname))//"_dx_SU" open(11,file=trim(filename),access='direct',status='old', & recl=240,iostat=ios) - if( ios /= 0 ) then + if ( ios /= 0 ) then print *,'error opening file: ',trim(filename) stop 'error opening data file' endif @@ -124,7 +124,7 @@ program SU_adjoint filename = trim(DATA_PATH)//trim(adjustl(procname))//"_d"//compstr(icomp)//"_SU" open(11,file=trim(filename),access='direct',status='old', & recl=240+4*NSTEP,iostat=ios) - if( ios /= 0 ) then + if ( ios /= 0 ) then print *,'error opening file: ',trim(filename) stop 'error opening input data file ' endif @@ -133,7 +133,7 @@ program SU_adjoint filename = trim(SYN_PATH)//trim(adjustl(procname))//"_d"//compstr(icomp)//"_SU" open(22,file=trim(filename),access='direct',status='old', & recl=240+4*NSTEP,iostat=ios) - if( ios /= 0 ) then + if ( ios /= 0 ) then print *,'error opening file: ',trim(filename) stop 'error opening input file ' endif @@ -142,7 +142,7 @@ program SU_adjoint filename = trim(ADJ_PATH)//trim(adjustl(procname))//"_d"//compstr(icomp)//"_SU"//".adj" open(33,file=trim(filename),access='direct',status='unknown', & recl=240+4*NSTEP,iostat = ios) - if( ios /= 0 ) then + if ( ios /= 0 ) then print *,'error opening file: ',trim(filename) stop 'error opening output file ' endif diff --git a/utils/adjoint_sources/amplitude/create_adjsrc_amplitude.f90 b/utils/adjoint_sources/amplitude/create_adjsrc_amplitude.f90 index ca06bb0f2..8070b5dfe 100644 --- a/utils/adjoint_sources/amplitude/create_adjsrc_amplitude.f90 +++ b/utils/adjoint_sources/amplitude/create_adjsrc_amplitude.f90 @@ -124,12 +124,12 @@ program create_adjsrc_amplitude ! time window (parabola shaped) tw(1:nstep) = 0. - if( i == i1 ) open(44,file='plot_time_window.txt',status='unknown') + if ( i == i1 ) open(44,file='plot_time_window.txt',status='unknown') do j = is, ie tw(j) = 1 - (2 * (dble(j) - is)/(ie - is) - 1) ** 2 - if( i == i1 ) write(44,*) j,tw(j) + if ( i == i1 ) write(44,*) j,tw(j) enddo - if( i == i1 ) close(44) + if ( i == i1 ) close(44) ! displacement array do itime = 1, nstep diff --git a/utils/adjoint_sources/traveltime/create_adjsrc_traveltime.f90 b/utils/adjoint_sources/traveltime/create_adjsrc_traveltime.f90 index eb1407f19..356187c8e 100644 --- a/utils/adjoint_sources/traveltime/create_adjsrc_traveltime.f90 +++ b/utils/adjoint_sources/traveltime/create_adjsrc_traveltime.f90 @@ -124,12 +124,12 @@ program create_adjsrc_traveltime ! time window (parabola shaped) tw(1:nstep) = 0. - if( i == i1 ) open(44,file='plot_time_window.txt',status='unknown') + if ( i == i1 ) open(44,file='plot_time_window.txt',status='unknown') do j = is, ie tw(j) = 1 - (2 * (dble(j) - is)/(ie - is) - 1) ** 2 - if( i == i1 ) write(44,*) j,tw(j) + if ( i == i1 ) write(44,*) j,tw(j) enddo - if( i == i1 ) close(44) + if ( i == i1 ) close(44) ! calculates velocity (by finite-differences) out(:) = 0.0 diff --git a/utils/clean_listings_specfem.pl b/utils/clean_listings_specfem.pl index c27ead181..3f8135f28 100755 --- a/utils/clean_listings_specfem.pl +++ b/utils/clean_listings_specfem.pl @@ -83,9 +83,8 @@ # read and clean all Fortran files in the current directory and subdirectories # -# @objects = `ls *.f90 *.F90 *.h *.h.in *.fh */*.f90 */*.F90 */*.h */*.h.in */*.fh */*/*.f90 */*/*.F90 */*/*.h */*/*.h.in */*/*.fh */*/*/*.f90 */*/*/*.F90 */*/*/*.h */*/*/*.h.in */*/*/*.fh`; # when using this "find" command from Perl we need to use \\ instead of \ below otherwise Perl tries to interpret it - @objects = `find . -name '.git' -prune -o -name 'm4' -prune -o -path './utils/ADJOINT_TOMOGRAPHY_TOOLS/flexwin' -prune -o -type f -regextype posix-extended -regex '.*\\.(fh|f90|F90|h|h\\.in)' -print`; + @objects = `find . -name '.git' -prune -o -name 'm4' -prune -o -path './utils/ADJOINT_TOMOGRAPHY_TOOLS/flexwin' -prune -o -type f -regextype posix-extended -regex '.*\\.(fh|f90|F90|h\\.in)' -print`; foreach $name (@objects) { chop $name; @@ -123,14 +122,35 @@ # in the code (which is dangerous, but really easier to program...) # # DK DK this could be dangerous if these words appear in strings or print statements + $line =~ s#if\s*\(#if \(#ogi; + $line =~ s#\)\s*then#\) then#ogi; $line =~ s#end\s*if#endif#ogi; $line =~ s#end\s*do#enddo#ogi; - $line =~ s# go\s*to # goto #ogi; $line =~ s#elseif#else if#ogi; + +# force lowercase keywords + $line =~ s#subroutine#subroutine#ogi; + $line =~ s#end\s*subroutine#end subroutine#ogi; + $line =~ s#function#function#ogi; + $line =~ s#end\s*function#end function#ogi; + $line =~ s#continue#continue#ogi; + $line =~ s#implicit none#implicit none#ogi; + $line =~ s#implicit#implicit#ogi; + + $line =~ s# go\s*to # goto #ogi; + $line =~ s#use\s*::\s*mpi#use mpi#ogi; - $line =~ s#enddo_LOOP_IJK#ENDDO_LOOP_IJK#ogi; + $line =~ s#print\s*\*#print \*#ogi; + $line =~ s#NOISE_SOURCE_TIME_FUNCTION_TYPE#noise_source_time_function_type#ogi; + +# do not move this before the above line in which we change the keyword "function" + $line =~ s#use_ricker_time_function#USE_RICKER_TIME_FUNCTION#ogi; + $line =~ s#print_source_time_function#PRINT_SOURCE_TIME_FUNCTION#ogi; + + $line =~ s#enddo_LOOP_IJK#ENDDO_LOOP_IJK#ogi; + $line =~ s#spectral-elements#spectral elements#ogi; $line =~ s#gaussian#Gaussian#ogi; @@ -138,8 +158,8 @@ # do not use null strings, which are not part of the Fortran standard (and the IBM xlf compiler rejects them for instance) $line =~ s#print\s*\*\s*,\s*''#print \*#ogi; $line =~ s#write\s*\(\s*\*\s*,\s*\*\s*\)\s*''#print \*#ogi; - $line =~ s#write\s*\(\s*IMAIN\s*,\s*\*\s*\)\s*''#write(IMAIN,\*)#ogi; - $line =~ s#write\s*\(\s*IOUT\s*,\s*\*\s*\)\s*''#write(IOUT,\*)#ogi; + $line =~ s#write\s*\(\s*IMAIN\s*,\s*\*\s*\)\s*''#write\(IMAIN,\*\)#ogi; + $line =~ s#write\s*\(\s*IOUT\s*,\s*\*\s*\)\s*''#write\(IOUT,\*\)#ogi; # always use upper case for GLL when used as a word $line =~ s# gll # GLL #ogi; diff --git a/utils/cmt_frechet/make_cmtsolution_files.f90 b/utils/cmt_frechet/make_cmtsolution_files.f90 index e85f9cf2a..3dbcfece5 100644 --- a/utils/cmt_frechet/make_cmtsolution_files.f90 +++ b/utils/cmt_frechet/make_cmtsolution_files.f90 @@ -44,7 +44,7 @@ program make_cmts character(len=256) string open(unit=1,file='CMTSOLUTION',iostat=ios,status='old') - if(ios /= 0) stop 'error opening CMT file ' + if (ios /= 0) stop 'error opening CMT file ' open(unit=2,file='CMTSOLUTION_latitude',iostat=ios,status='unknown') open(unit=3,file='CMTSOLUTION_longitude',iostat=ios,status='unknown') @@ -71,42 +71,42 @@ program make_cmts read(1,"(a)",iostat=ios) string - if(ios == 0) then + if (ios == 0) then lstr=len_trim(string) - if(string(1:10) == 'event name') then + if (string(1:10) == 'event name') then do iu=2,10 write(iu,"(a)") string(1:lstr) enddo - else if(string(1:10) == 'time shift') then + else if (string(1:10) == 'time shift') then read(string(12:lstr),*) tshift_cmt do iu=2,10 write(iu,"(a)") string(1:lstr) enddo - else if(string(1:13) == 'half duration') then + else if (string(1:13) == 'half duration') then read(string(15:lstr),*) hdur do iu=2,10 write(iu,"(a)") string(1:lstr) enddo - else if(string(1:8) == 'latitude') then + else if (string(1:8) == 'latitude') then read(string(10:lstr),*) lat latp = lat + DDELTA - if(latp > 90.0) latp = 180.0 - latp + if (latp > 90.0) latp = 180.0 - latp write(2,"(a9,5x,f9.4)") string(1:9),latp do iu=3,10 write(iu,"(a)") string(1:lstr) enddo - else if(string(1:9) == 'longitude') then + else if (string(1:9) == 'longitude') then read(string(11:lstr),*) long write(2,"(a)") string(1:lstr) longp = long + DDELTA - if(longp > 180.0) longp = longp - 360.0 + if (longp > 180.0) longp = longp - 360.0 write(3,"(a10,4x,f9.4)") string(1:10),longp do iu=4,10 write(iu,"(a)") string(1:lstr) enddo - else if(string(1:5) == 'depth') then + else if (string(1:5) == 'depth') then read(string(7:lstr),*) depth write(2,"(a)") string(1:lstr) write(3,"(a)") string(1:lstr) @@ -114,7 +114,7 @@ program make_cmts do iu=5,10 write(iu,"(a)") string(1:lstr) enddo - else if(string(1:3) == 'Mrr') then + else if (string(1:3) == 'Mrr') then read(string(5:lstr),*) moment_tensor(1) do iu=2,4 write(iu,"(a)") string(1:lstr) @@ -125,7 +125,7 @@ program make_cmts write(8,"(a4,4x,e15.6)") string(1:4),0.0 write(9,"(a4,4x,e15.6)") string(1:4),0.0 write(10,"(a4,4x,e15.6)") string(1:4),0.0 - else if(string(1:3) == 'Mtt') then + else if (string(1:3) == 'Mtt') then read(string(5:lstr),*) moment_tensor(2) do iu=2,4 write(iu,"(a)") string(1:lstr) @@ -136,7 +136,7 @@ program make_cmts write(8,"(a4,4x,e15.6)") string(1:4),0.0 write(9,"(a4,4x,e15.6)") string(1:4),0.0 write(10,"(a4,4x,e15.6)") string(1:4),0.0 - else if(string(1:3) == 'Mpp') then + else if (string(1:3) == 'Mpp') then read(string(5:lstr),*) moment_tensor(3) do iu=2,4 write(iu,"(a)") string(1:lstr) @@ -147,7 +147,7 @@ program make_cmts write(8,"(a4,4x,e15.6)") string(1:4),0.0 write(9,"(a4,4x,e15.6)") string(1:4),0.0 write(10,"(a4,4x,e15.6)") string(1:4),0.0 - else if(string(1:3) == 'Mrt') then + else if (string(1:3) == 'Mrt') then read(string(5:lstr),*) moment_tensor(4) do iu=2,4 write(iu,"(a)") string(1:lstr) @@ -158,7 +158,7 @@ program make_cmts write(8,"(a4,4x,e15.6)") string(1:4),MOMENT write(9,"(a4,4x,e15.6)") string(1:4),0.0 write(10,"(a4,4x,e15.6)") string(1:4),0.0 - else if(string(1:3) == 'Mrp') then + else if (string(1:3) == 'Mrp') then read(string(5:lstr),*) moment_tensor(5) do iu=2,4 write(iu,"(a)") string(1:lstr) @@ -169,7 +169,7 @@ program make_cmts write(8,"(a4,4x,e15.6)") string(1:4),0.0 write(9,"(a4,4x,e15.6)") string(1:4),MOMENT write(10,"(a4,4x,e15.6)") string(1:4),0.0 - else if(string(1:3) == 'Mtp') then + else if (string(1:3) == 'Mtp') then read(string(5:lstr),*) moment_tensor(6) do iu=2,4 write(iu,"(a)") string(1:lstr) @@ -210,7 +210,7 @@ integer function julian_day(yr,mo,da) data mon /0,31,59,90,120,151,181,212,243,273,304,334/ julian_day=da+mon(mo) - if(mo>2) julian_day=julian_day+lpyr(yr) + if (mo>2) julian_day=julian_day+lpyr(yr) end function julian_day @@ -222,11 +222,11 @@ integer function lpyr(yr) !---- returns 1 if yr is a leap year ! lpyr=0 - if(mod(yr,400) == 0) then + if (mod(yr,400) == 0) then lpyr=1 - else if(mod(yr,4) == 0) then + else if (mod(yr,4) == 0) then lpyr=1 - if(mod(yr,100) == 0) then + if (mod(yr,100) == 0) then lpyr=0 endif endif diff --git a/utils/compute_expression_of_potential_energy.f90 b/utils/compute_expression_of_potential_energy.f90 index 37266c4c7..e90629b89 100644 --- a/utils/compute_expression_of_potential_energy.f90 +++ b/utils/compute_expression_of_potential_energy.f90 @@ -17,7 +17,7 @@ program expression_total_energy ! 1 = x, 2 = y and 3 = z do i = 1,3 do j = 1,3 - if(i == 3 .and. j == 3) then + if (i == 3 .and. j == 3) then print *,'sigma_',i,j,' * epsilon_',i,j,')' else print *,'sigma_',i,j,' * epsilon_',i,j,' + ' diff --git a/utils/lib/utm_geo.f90 b/utils/lib/utm_geo.f90 index 6d0ec4d58..603cd1d56 100644 --- a/utils/lib/utm_geo.f90 +++ b/utils/lib/utm_geo.f90 @@ -48,7 +48,7 @@ subroutine utm_geo(rlon,rlat,rx,ry,UTM_PROJECTION_ZONE,iway) double precision f1,f2,f3,f4,rm,rn,t,c,a,e1,u,rlat1,dlat1,c1,t1,rn1,r1,d double precision rx_save,ry_save,rlon_save,rlat_save - if(SUPPRESS_UTM_PROJECTION) then + if (SUPPRESS_UTM_PROJECTION) then if (iway == ILONGLAT2UTM) then rx = rlon ry = rlat diff --git a/utils/locate_partition.f90 b/utils/locate_partition.f90 index a979a62ed..e79b0f167 100644 --- a/utils/locate_partition.f90 +++ b/utils/locate_partition.f90 @@ -105,28 +105,28 @@ program locate_partition write(prname_lp,'(a,i6.6,a)') trim(LOCAL_PATH)//'/proc',iproc,'_' open(unit=27,file=prname_lp(1:len_trim(prname_lp))//'external_mesh.bin',& status='old',action='read',form='unformatted',iostat=ios) - if( ios /= 0 ) exit + if ( ios /= 0 ) exit read(27,iostat=ier) NSPEC_AB - if( ier /= 0 ) stop 'please check your compilation, use the same compiler & flags as for SPECFEM3D' + if ( ier /= 0 ) stop 'please check your compilation, use the same compiler & flags as for SPECFEM3D' read(27,iostat=ier) NGLOB_AB - if( ier /= 0 ) stop 'please check your compilation, use the same compiler & flags as for SPECFEM3D' + if ( ier /= 0 ) stop 'please check your compilation, use the same compiler & flags as for SPECFEM3D' ! ibool file allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier) - if( ier /= 0 ) stop 'error allocating array ibool' + if ( ier /= 0 ) stop 'error allocating array ibool' read(27,iostat=ier) ibool - if( ier /= 0 ) stop 'please check your compilation, use the same compiler & flags as for SPECFEM3D' + if ( ier /= 0 ) stop 'please check your compilation, use the same compiler & flags as for SPECFEM3D' ! global point arrays allocate(xstore(NGLOB_AB),ystore(NGLOB_AB),zstore(NGLOB_AB),stat=ier) - if( ier /= 0 ) stop 'error allocating array xstore etc.' + if ( ier /= 0 ) stop 'error allocating array xstore etc.' read(27,iostat=ier) xstore - if( ier /= 0 ) stop 'please check your compilation, use the same compiler & flags as for SPECFEM3D' + if ( ier /= 0 ) stop 'please check your compilation, use the same compiler & flags as for SPECFEM3D' read(27,iostat=ier) ystore - if( ier /= 0 ) stop 'please check your compilation, use the same compiler & flags as for SPECFEM3D' + if ( ier /= 0 ) stop 'please check your compilation, use the same compiler & flags as for SPECFEM3D' read(27,iostat=ier) zstore - if( ier /= 0 ) stop 'please check your compilation, use the same compiler & flags as for SPECFEM3D' + if ( ier /= 0 ) stop 'please check your compilation, use the same compiler & flags as for SPECFEM3D' close(27) print *,'partition: ',iproc @@ -142,7 +142,7 @@ program locate_partition NGLOB_AB,NSPEC_AB,xstore,ystore,zstore,ibool, & distance,x_found,y_found,z_found) - if( distance < total_distance ) then + if ( distance < total_distance ) then total_distance = distance total_partition = iproc total_x = x_found @@ -215,7 +215,7 @@ subroutine get_closest_point(target_x,target_y,target_z, & + (target_y - ystore(iglob))*(target_y - ystore(iglob)) & + (target_z - zstore(iglob))*(target_z - zstore(iglob)) - if( dist < distance ) then + if ( dist < distance ) then distance = dist x_found = xstore(iglob) y_found = ystore(iglob) diff --git a/utils/sac2000_alpha_convert/convert_files_sacalpha_ascii.f90 b/utils/sac2000_alpha_convert/convert_files_sacalpha_ascii.f90 index 0ba4e716c..158bc027f 100644 --- a/utils/sac2000_alpha_convert/convert_files_sacalpha_ascii.f90 +++ b/utils/sac2000_alpha_convert/convert_files_sacalpha_ascii.f90 @@ -38,19 +38,19 @@ program sac_convert read(5,*) val1,val2,val3,val4,val5 it = it + 1 - if(t0 + (it-1)*dt >= 0 .or. ALSO_OUTPUT_NEGATIVE_TIMES) write(*,*) sngl(t0 + (it-1)*dt),sngl(val1) + if (t0 + (it-1)*dt >= 0 .or. ALSO_OUTPUT_NEGATIVE_TIMES) write(*,*) sngl(t0 + (it-1)*dt),sngl(val1) it = it + 1 - if(t0 + (it-1)*dt >= 0 .or. ALSO_OUTPUT_NEGATIVE_TIMES) write(*,*) sngl(t0 + (it-1)*dt),sngl(val2) + if (t0 + (it-1)*dt >= 0 .or. ALSO_OUTPUT_NEGATIVE_TIMES) write(*,*) sngl(t0 + (it-1)*dt),sngl(val2) it = it + 1 - if(t0 + (it-1)*dt >= 0 .or. ALSO_OUTPUT_NEGATIVE_TIMES) write(*,*) sngl(t0 + (it-1)*dt),sngl(val3) + if (t0 + (it-1)*dt >= 0 .or. ALSO_OUTPUT_NEGATIVE_TIMES) write(*,*) sngl(t0 + (it-1)*dt),sngl(val3) it = it + 1 - if(t0 + (it-1)*dt >= 0 .or. ALSO_OUTPUT_NEGATIVE_TIMES) write(*,*) sngl(t0 + (it-1)*dt),sngl(val4) + if (t0 + (it-1)*dt >= 0 .or. ALSO_OUTPUT_NEGATIVE_TIMES) write(*,*) sngl(t0 + (it-1)*dt),sngl(val4) it = it + 1 - if(t0 + (it-1)*dt >= 0 .or. ALSO_OUTPUT_NEGATIVE_TIMES) write(*,*) sngl(t0 + (it-1)*dt),sngl(val5) + if (t0 + (it-1)*dt >= 0 .or. ALSO_OUTPUT_NEGATIVE_TIMES) write(*,*) sngl(t0 + (it-1)*dt),sngl(val5) enddo diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/add_topography.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/add_topography.f90 index 665ff443f..c0923416a 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/add_topography.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/add_topography.f90 @@ -75,7 +75,7 @@ subroutine add_topography(myrank,xelm,yelm,zelm,ibathy_topo,R220) ! add elevation to all the points of that element ! also make sure gamma makes sense - if(gamma < -0.02 .or. gamma > 1.02) call exit_MPI(myrank,'incorrect value of gamma for topography') + if (gamma < -0.02 .or. gamma > 1.02) call exit_MPI(myrank,'incorrect value of gamma for topography') xelm(ia) = xelm(ia)*(ONE + gamma * elevation / r) yelm(ia) = yelm(ia)*(ONE + gamma * elevation / r) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/add_topography_410_650.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/add_topography_410_650.f90 index 76592607c..fe471ac8b 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/add_topography_410_650.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/add_topography_410_650.f90 @@ -107,26 +107,26 @@ subroutine add_topography_410_650(myrank,xelm,yelm,zelm,R220,R400,R670,R771, & topo650 = -dble(topo650out) / R_EARTH_KM gamma = 0.d0 - if(r >= R400/R_EARTH .and. r <= R220/R_EARTH) then + if (r >= R400/R_EARTH .and. r <= R220/R_EARTH) then ! stretching between R220 and R400 gamma = (R220/R_EARTH - r) / (R220/R_EARTH - R400/R_EARTH) xelm(ia) = xelm(ia)*(ONE + gamma * topo410 / r) yelm(ia) = yelm(ia)*(ONE + gamma * topo410 / r) zelm(ia) = zelm(ia)*(ONE + gamma * topo410 / r) - else if(r>= R771/R_EARTH .and. r <= R670/R_EARTH) then + else if (r>= R771/R_EARTH .and. r <= R670/R_EARTH) then ! stretching between R771 and R670 gamma = (r - R771/R_EARTH) / (R670/R_EARTH - R771/R_EARTH) xelm(ia) = xelm(ia)*(ONE + gamma * topo650 / r) yelm(ia) = yelm(ia)*(ONE + gamma * topo650 / r) zelm(ia) = zelm(ia)*(ONE + gamma * topo650 / r) - else if(r > R670/R_EARTH .and. r < R400/R_EARTH) then + else if (r > R670/R_EARTH .and. r < R400/R_EARTH) then ! stretching between R670 and R400 gamma = (R400/R_EARTH - r) / (R400/R_EARTH - R670/R_EARTH) xelm(ia) = xelm(ia)*(ONE + (topo410 + gamma * (topo650 - topo410)) / r) yelm(ia) = yelm(ia)*(ONE + (topo410 + gamma * (topo650 - topo410)) / r) zelm(ia) = zelm(ia)*(ONE + (topo410 + gamma * (topo650 - topo410)) / r) endif - if(gamma < -0.0001 .or. gamma > 1.0001) call exit_MPI(myrank,'incorrect value of gamma for 410-650 topography') + if (gamma < -0.0001 .or. gamma > 1.0001) call exit_MPI(myrank,'incorrect value of gamma for 410-650 topography') enddo diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/add_topography_cmb.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/add_topography_cmb.f90 index 6a9879aea..f667a55de 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/add_topography_cmb.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/add_topography_cmb.f90 @@ -65,14 +65,14 @@ subroutine add_topography_cmb(myrank,xelm,yelm,zelm,RTOPDDOUBLEPRIME,RCMB) ! and finish at RTOPDDOUBLEPRIME (D'') r_start = (RCMB - (RTOPDDOUBLEPRIME - RCMB))/R_EARTH gamma = 0.0d0 - if(r >= RCMB/R_EARTH .and. r <= RTOPDDOUBLEPRIME/R_EARTH) then + if (r >= RCMB/R_EARTH .and. r <= RTOPDDOUBLEPRIME/R_EARTH) then ! stretching between RCMB and RTOPDDOUBLEPRIME gamma = (RTOPDDOUBLEPRIME/R_EARTH - r) / (RTOPDDOUBLEPRIME/R_EARTH - RCMB/R_EARTH) - else if(r>= r_start .and. r <= RCMB/R_EARTH) then + else if (r>= r_start .and. r <= RCMB/R_EARTH) then ! stretching between r_start and RCMB gamma = (r - r_start) / (RCMB/R_EARTH - r_start) endif - if(gamma < -0.0001 .or. gamma > 1.0001) call exit_MPI(myrank,'incorrect value of gamma for CMB topography') + if (gamma < -0.0001 .or. gamma > 1.0001) call exit_MPI(myrank,'incorrect value of gamma for CMB topography') xelm(ia) = xelm(ia)*(ONE + gamma * topocmb / r) yelm(ia) = yelm(ia)*(ONE + gamma * topocmb / r) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/add_topography_icb.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/add_topography_icb.f90 index 71fa9d27f..b3c0fca9c 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/add_topography_icb.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/add_topography_icb.f90 @@ -62,14 +62,14 @@ subroutine add_topography_icb(myrank,xelm,yelm,zelm,RICB,RCMB) topoicb = -topoicb / R_EARTH_KM gamma = 0.0d0 - if(r > 0.0d0 .and. r <= RICB/R_EARTH) then + if (r > 0.0d0 .and. r <= RICB/R_EARTH) then ! stretching between center and RICB gamma = r/(RICB/R_EARTH) - else if(r>= RICB/R_EARTH .and. r <= RCMB/R_EARTH) then + else if (r>= RICB/R_EARTH .and. r <= RCMB/R_EARTH) then ! stretching between RICB and RCMB gamma = (r - RCMB/R_EARTH) / (RICB/R_EARTH - RCMB/R_EARTH) endif - if(gamma < -0.0001 .or. gamma > 1.0001) call exit_MPI(myrank,'incorrect value of gamma for CMB topography') + if (gamma < -0.0001 .or. gamma > 1.0001) call exit_MPI(myrank,'incorrect value of gamma for CMB topography') xelm(ia) = xelm(ia)*(ONE + gamma * topoicb / r) yelm(ia) = yelm(ia)*(ONE + gamma * topoicb / r) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/anisotropic_inner_core_model.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/anisotropic_inner_core_model.f90 index 4d17bf48b..4e000405b 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/anisotropic_inner_core_model.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/anisotropic_inner_core_model.f90 @@ -52,7 +52,7 @@ subroutine aniso_inner_core_model(x,c11,c33,c12,c13,c44,REFERENCE_1D_MODEL) double precision c66 double precision scale_fac - if(REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) then + if (REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) then vp=11.24094d0-4.09689d0*x*x vs=3.56454d0-3.45241d0*x*x rho=13.0885d0-8.8381d0*x*x @@ -62,7 +62,7 @@ subroutine aniso_inner_core_model(x,c11,c33,c12,c13,c44,REFERENCE_1D_MODEL) vs0=3.56454d0 rho0=13.0885d0 - else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_PREM) then + else if (REFERENCE_1D_MODEL == REFERENCE_MODEL_PREM) then vp=11.2622d0-6.3640d0*x*x vs=3.6678d0-4.4475d0*x*x rho=13.0885d0-8.8381d0*x*x diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/anisotropic_mantle_model.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/anisotropic_mantle_model.f90 index 528d65cb1..d55733448 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/anisotropic_mantle_model.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/anisotropic_mantle_model.f90 @@ -121,14 +121,14 @@ subroutine build_cij(pro,npar1,rho,beta,r,theta,phi,& nz0 = 34 ! avoid edge effects - if(theta==0.0d0) theta=0.000001d0 - if(theta==180.d0) theta=0.999999d0*theta - if(phi==0.0d0) phi=0.000001d0 - if(phi==360.d0) phi=0.999999d0*phi + if (theta==0.0d0) theta=0.000001d0 + if (theta==180.d0) theta=0.999999d0*theta + if (phi==0.0d0) phi=0.000001d0 + if (phi==360.d0) phi=0.999999d0*phi ! dimensionalize depth = R_EARTH_KM*(R_UNIT_SPHERE - r) - if(depth <= pro(nz0) .or. depth >= pro(1)) call exit_MPI_without_rank('r out of range in build_cij') + if (depth <= pro(nz0) .or. depth >= pro(1)) call exit_MPI_without_rank('r out of range in build_cij') itheta = int(theta + pxy0)/pxy0 ilon = int(phi + pxy0)/pxy0 tet = theta @@ -136,7 +136,7 @@ subroutine build_cij(pro,npar1,rho,beta,r,theta,phi,& icz0 = 0 do idep = 1,ndepth - if(pro(idep) > depth) icz0 = icz0 + 1 + if (pro(idep) > depth) icz0 = icz0 + 1 enddo ! @@ -153,12 +153,12 @@ subroutine build_cij(pro,npar1,rho,beta,r,theta,phi,& icz1 = icz0 + 1 ! check that parameters make sense - if(ict0 < 1 .or. ict0 > nx0) call exit_MPI_without_rank('ict0 out of range') - if(ict1 < 1 .or. ict1 > nx0) call exit_MPI_without_rank('ict1 out of range') - if(icp0 < 1 .or. icp0 > ny0) call exit_MPI_without_rank('icp0 out of range') - if(icp1 < 1 .or. icp1 > ny0) call exit_MPI_without_rank('icp1 out of range') - if(icz0 < 1 .or. icz0 > nz0) call exit_MPI_without_rank('icz0 out of range') - if(icz1 < 1 .or. icz1 > nz0) call exit_MPI_without_rank('icz1 out of range') + if (ict0 < 1 .or. ict0 > nx0) call exit_MPI_without_rank('ict0 out of range') + if (ict1 < 1 .or. ict1 > nx0) call exit_MPI_without_rank('ict1 out of range') + if (icp0 < 1 .or. icp0 > ny0) call exit_MPI_without_rank('icp0 out of range') + if (icp1 < 1 .or. icp1 > ny0) call exit_MPI_without_rank('icp1 out of range') + if (icz0 < 1 .or. icz0 > nz0) call exit_MPI_without_rank('icz0 out of range') + if (icz1 < 1 .or. icz1 > nz0) call exit_MPI_without_rank('icz1 out of range') do ipar = 1,14 anispara(ipar,1,1) = beta(ipar,icz0,ict0,icp0) @@ -200,7 +200,7 @@ subroutine build_cij(pro,npar1,rho,beta,r,theta,phi,& eps = 0.01 do ipar = 1,14 - if(thickness < eps)then + if (thickness < eps) then pc1 = anispara(ipar,1,1) pc2 = anispara(ipar,1,2) pc3 = anispara(ipar,1,3) @@ -375,11 +375,11 @@ subroutine read_aniso_mantle_model(AMM_V) ppp = 1. read(19,"(f5.0,f8.4)",end = 88) AMM_V%pro(idep),ppp - if(nf == 1) pari(nf,il) = ppp - if(nf == 2) pari(nf,il) = ppp - if(nf == 3) pari(nf,il) = ppp - if(nf == 4) ppp = pari(nf,il) - if(nf == 5) ppp = pari(nf,il) + if (nf == 1) pari(nf,il) = ppp + if (nf == 2) pari(nf,il) = ppp + if (nf == 3) pari(nf,il) = ppp + if (nf == 4) ppp = pari(nf,il) + if (nf == 5) ppp = pari(nf,il) do ilat = 1,nx read(19,"(17f7.2)",end = 88) (AMM_V%beta(ipa,idep,ilat,ilon),ilon = 1,ny) ! @@ -391,11 +391,11 @@ subroutine read_aniso_mantle_model(AMM_V) ! bet2(11,...)=Hc, bet2(12,...)=Hs,bet2(13,...)=Ec,bet2(14,...)=Es ! do ilon = 1,ny - if(nf <= 3 .or. nf >= 6)then + if (nf <= 3 .or. nf >= 6) then bet2(ipa,idep,ilat,ilon) = AMM_V%beta(ipa,idep,ilat,ilon)*0.01*ppp + ppp else - if(nf == 4)bet2(ipa,idep,ilat,ilon) = AMM_V%beta(ipa,idep,ilat,ilon)*0.01 + 1. - if(nf == 5)bet2(ipa,idep,ilat,ilon) = - AMM_V%beta(ipa,idep,ilat,ilon)*0.01 + 1. + if (nf == 4)bet2(ipa,idep,ilat,ilon) = AMM_V%beta(ipa,idep,ilat,ilon)*0.01 + 1. + if (nf == 5)bet2(ipa,idep,ilat,ilon) = - AMM_V%beta(ipa,idep,ilat,ilon)*0.01 + 1. endif enddo @@ -422,11 +422,11 @@ subroutine read_aniso_mantle_model(AMM_V) il = idep + np1 - 1 read(15,"(2f4.0,2i3,f4.0)",end = 888) xinf,yinf,nx,ny,pxy read(15,"(f5.0,f8.4)",end = 888) AMM_V%pro(idep),ppp - if(nf == 7) ppp = pari(2,il) - if(nf == 9) ppp = pari(3,il) + if (nf == 7) ppp = pari(2,il) + if (nf == 9) ppp = pari(3,il) af = pari(6,il)*(pari(2,il) - 2.*pari(3,il)) - if(nf == 11) ppp = af - if(nf == 13) ppp = (pari(4,il) + 1.)*pari(3,il) + if (nf == 11) ppp = af + if (nf == 13) ppp = (pari(4,il) + 1.)*pari(3,il) do ilat = 1,nx read(15,"(17f7.2)",end = 888) (alph(ilon,ilat),ilon = 1,ny) @@ -513,7 +513,7 @@ subroutine lecmod(nri,pari,ra) open(unit=13,file=Adrem119,status='old',action='read') read(13,*,end = 77) nlayer,minlay,moho,nout,neff,nband,kiti,null - if(kiti == 0) read(13,"(20a4)",end = 77) idum1 + if (kiti == 0) read(13,"(20a4)",end = 77) idum1 read(13,"(20a4)",end = 77) idum2 read(13,"(20a4)",end = 77) idum3 @@ -549,7 +549,7 @@ subroutine lecmod(nri,pari,ra) enddo vsv = 0. vsh = 0. - if(al < 0.0001 .or. an < 0.0001) goto 12 + if (al < 0.0001 .or. an < 0.0001) goto 12 vsv = dsqrt(al/rho) vsh = dsqrt(an/rho) 12 vpv = dsqrt(ac/rho) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/auto_ner.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/auto_ner.f90 index 20eb7bfdd..361028b50 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/auto_ner.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/auto_ner.f90 @@ -114,7 +114,7 @@ subroutine auto_attenuation_periods(WIDTH, NEX_MAX, MIN_ATTENUATION_PERIOD, MAX_ S_VELOCITY_MIN MIN_ATTENUATION_PERIOD = TMP - if(N_SLS < 2 .or. N_SLS > 5) then + if (N_SLS < 2 .or. N_SLS > 5) then call exit_MPI_without_rank('N_SLS must be greater than 1 or less than 6') endif @@ -181,7 +181,7 @@ subroutine auto_ner(WIDTH, NEX_MAX, & ! Minimum Number of Elements a Region must have NER(:) = 1 NER(3:5) = 2 - if(CASE_3D) then + if (CASE_3D) then NER(1) = 2 endif @@ -297,7 +297,7 @@ subroutine find_r_central_cube(nex_xi_in, rcube, nex_eta_in) ! xi = abs(rcube_test - 981.0d0) / 45.0d0 ! write(*,'(a,5(f14.4,2x))')'rcube, xi, ximin:-',rcube_test, xi, min_edgemin,max_edgemax,max_aspect_ratio deallocate(points) - if(xi < ximin) then + if (xi < ximin) then ximin = xi rcube = rcube_test nex_eta_in = nex_eta @@ -334,7 +334,7 @@ subroutine compute_nex(nex_xi, rcube, alpha, ner) surfy = RICB_KM * sin(3 * (PI/4.0d0) - ratio_x * (PI/2.0d0)) dist_cc_icb = sqrt((surfx -x)**2 + (surfy - y)**2) - if(ix /= nex_xi/2) then + if (ix /= nex_xi/2) then dist_cc_icb = dist_cc_icb * 2 endif somme = somme + dist_cc_icb @@ -485,7 +485,7 @@ subroutine compute_coordinate(ix,iy,nbx, nby, rcube, ic, alpha, x, y) x = xsurf - ratio_y * deltax y = ysurf - ratio_y * deltay - if(ic == 1) then + if (ic == 1) then temp = x x = y y = temp diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/calc_jacobian.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/calc_jacobian.f90 index d9e85bf7c..b4e21cb26 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/calc_jacobian.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/calc_jacobian.f90 @@ -104,7 +104,7 @@ subroutine calc_jacobian(myrank,xixstore,xiystore,xizstore, & xeta*(yxi*zgamma-ygamma*zxi) + & xgamma*(yxi*zeta-yeta*zxi) - if(jacobian <= ZERO) call exit_MPI(myrank,'3D Jacobian undefined') + if (jacobian <= ZERO) call exit_MPI(myrank,'3D Jacobian undefined') ! invert the relation (Fletcher p. 50 vol. 2) xix = (yeta*zgamma-ygamma*zeta) / jacobian @@ -119,8 +119,8 @@ subroutine calc_jacobian(myrank,xixstore,xiystore,xizstore, & ! save the derivatives and the jacobian ! distinguish between single and double precision for reals - if(ACTUALLY_STORE_ARRAYS) then - if(CUSTOM_REAL == SIZE_REAL) then + if (ACTUALLY_STORE_ARRAYS) then + if (CUSTOM_REAL == SIZE_REAL) then xixstore(i,j,k,ispec) = sngl(xix) xiystore(i,j,k,ispec) = sngl(xiy) xizstore(i,j,k,ispec) = sngl(xiz) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/combine_AVS_DX.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/combine_AVS_DX.f90 index 5e4ba9158..4c94d8481 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/combine_AVS_DX.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/combine_AVS_DX.f90 @@ -207,7 +207,7 @@ program combine_AVS_DX WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.) - if(.not. SAVE_MESH_FILES) stop 'AVS or DX files were not saved by the mesher' + if (.not. SAVE_MESH_FILES) stop 'AVS or DX files were not saved by the mesher' ! get the base pathname for output files call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES') @@ -218,8 +218,8 @@ program combine_AVS_DX print * print *,'enter value:' read(5,*) iformat - if(iformat<1 .or. iformat>2) stop 'exiting...' - if(iformat == 1) then + if (iformat<1 .or. iformat>2) stop 'exiting...' + if (iformat == 1) then USE_OPENDX = .true. else USE_OPENDX = .false. @@ -233,10 +233,10 @@ program combine_AVS_DX print * print *,'enter value:' read(5,*) ivalue - if(ivalue<1 .or. ivalue>3) stop 'exiting...' + if (ivalue<1 .or. ivalue>3) stop 'exiting...' ! warning if surface elevation - if(ivalue == 3) then + if (ivalue == 3) then print *,'******************************************' print *,'*** option 7 to color using topography ***' print *,'******************************************' @@ -256,11 +256,11 @@ program combine_AVS_DX print * print *,'enter value:' read(5,*) icolor - if(icolor<1 .or. icolor >9) stop 'exiting...' - if((icolor == 3 .or. icolor == 4) .and. ivalue /= 2) & + if (icolor<1 .or. icolor >9) stop 'exiting...' + if ((icolor == 3 .or. icolor == 4) .and. ivalue /= 2) & stop 'need chunks only to represent stability or gridpoints per wavelength' - if(icolor == 9) then + if (icolor == 9) then print * print *,'enter value of target doubling flag:' read(5,*) itarget_doubling @@ -268,15 +268,15 @@ program combine_AVS_DX ! for oceans only OCEANS_ONLY = .false. - if(ivalue == 3 .and. icolor == 7) then + if (ivalue == 3 .and. icolor == 7) then print * print *,'1 = represent full topography (topo + oceans)' print *,'2 = represent oceans only' print * read(5,*) ioceans - if(ioceans == 1) then + if (ioceans == 1) then OCEANS_ONLY = .false. - else if(ioceans == 2) then + else if (ioceans == 2) then OCEANS_ONLY = .true. else stop 'incorrect option for the oceans' @@ -292,24 +292,24 @@ program combine_AVS_DX print * print *,'enter value:' read(5,*) imaterial - if(imaterial < 1 .or. imaterial > 4) stop 'exiting...' + if (imaterial < 1 .or. imaterial > 4) stop 'exiting...' ! user can specify a range of processors here print * print *,'enter first proc (proc numbers start at 0) = ' read(5,*) proc_p1 - if(proc_p1 < 0) proc_p1 = 0 - if(proc_p1 > NPROCTOT-1) proc_p1 = NPROCTOT-1 + if (proc_p1 < 0) proc_p1 = 0 + if (proc_p1 > NPROCTOT-1) proc_p1 = NPROCTOT-1 print *,'enter last proc (enter -1 for all procs) = ' read(5,*) proc_p2 - if(proc_p2 == -1) proc_p2 = NPROCTOT-1 - if(proc_p2 < 0) proc_p2 = 0 - if(proc_p2 > NPROCTOT-1) proc_p2 = NPROCTOT-1 + if (proc_p2 == -1) proc_p2 = NPROCTOT-1 + if (proc_p2 < 0) proc_p2 = 0 + if (proc_p2 > NPROCTOT-1) proc_p2 = NPROCTOT-1 ! set interval to maximum if user input is not correct - if(proc_p1 <= 0) proc_p1 = 0 - if(proc_p2 < 0) proc_p2 = NPROCTOT - 1 + if (proc_p1 <= 0) proc_p1 = 0 + if (proc_p2 < 0) proc_p2 = NPROCTOT - 1 print * print *,'There are ',NPROCTOT,' slices numbered from 0 to ',NPROCTOT-1 @@ -324,7 +324,7 @@ program combine_AVS_DX ! open(unit=IIN,file=trim(OUTPUT_FILES)//'/addressing.txt',status='old',action='read') do iproc = 0,NPROCTOT-1 ! read(IIN,*) iproc_read,ichunk,idummy1,idummy2 -! if(iproc_read /= iproc) stop 'incorrect slice number read' +! if (iproc_read /= iproc) stop 'incorrect slice number read' !! DK DK added this: only one chunk for the GPU version for now ichunk = 1 !! DK DK added this: only one chunk for the GPU version for now @@ -368,7 +368,7 @@ program combine_AVS_DX region_max = MAX_NUM_REGIONS ! if representing surface elements, only one region - if(ivalue == 3) then + if (ivalue == 3) then region_min = IREGION_CRUST_MANTLE region_max = IREGION_CRUST_MANTLE endif @@ -389,11 +389,11 @@ program combine_AVS_DX call create_serial_name_database(prname,iproc,iregion_code, & LOCAL_PATH,NPROCTOT,OUTPUT_FILES) - if(ivalue == 1) then + if (ivalue == 1) then open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointsfaces.txt',status='old',action='read') - else if(ivalue == 2) then + else if (ivalue == 2) then open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointschunks.txt',status='old',action='read') - else if(ivalue == 3) then + else if (ivalue == 3) then open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointssurface.txt',status='old',action='read') endif @@ -402,11 +402,11 @@ program combine_AVS_DX ntotpoin = ntotpoin + npoin close(10) - if(ivalue == 1) then + if (ivalue == 1) then open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementsfaces.txt',status='old',action='read') - else if(ivalue == 2) then + else if (ivalue == 2) then open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementschunks.txt',status='old',action='read') - else if(ivalue == 3) then + else if (ivalue == 3) then open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementssurface.txt',status='old',action='read') endif @@ -427,7 +427,7 @@ program combine_AVS_DX ntotspecAVS_DX = ntotspec ! write AVS or DX header with element data - if(USE_OPENDX) then + if (USE_OPENDX) then open(unit=11,file=trim(OUTPUT_FILES)//'/DX_fullmesh.dx',status='unknown') write(11,*) 'object 1 class array type float rank 1 shape 3 items ',ntotpoinAVS_DX,' data follows' else @@ -463,12 +463,12 @@ program combine_AVS_DX call create_serial_name_database(prname,iproc,iregion_code, & LOCAL_PATH,NPROCTOT,OUTPUT_FILES) - if(ivalue == 1) then + if (ivalue == 1) then open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointsfaces.txt',status='old',action='read') - else if(ivalue == 2) then + else if (ivalue == 2) then open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointschunks.txt',status='old',action='read') open(unit=12,file=prname(1:len_trim(prname))//'AVS_DXpointschunks_stability.txt',status='old',action='read') - else if(ivalue == 3) then + else if (ivalue == 3) then open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointssurface.txt',status='old',action='read') endif @@ -478,17 +478,17 @@ program combine_AVS_DX ! read local points in this slice and output global AVS or DX points do ipoin=1,npoin read(10,*) numpoin,xval,yval,zval - if(ivalue == 2) then + if (ivalue == 2) then read(12,*) numpoin2,vmin,vmax else numpoin2 = 0 vmin = 0. vmax = 0. endif - if(numpoin /= ipoin) stop 'incorrect point number' - if(ivalue == 2 .and. numpoin2 /= ipoin) stop 'incorrect point number' + if (numpoin /= ipoin) stop 'incorrect point number' + if (ivalue == 2 .and. numpoin2 /= ipoin) stop 'incorrect point number' ! write to AVS or DX global file with correct offset - if(USE_OPENDX) then + if (USE_OPENDX) then write(11,"(f10.7,1x,f10.7,1x,f10.7)") xval,yval,zval else write(11,"(i6,1x,f10.7,1x,f10.7,1x,f10.7)") numpoin + iglobpointoffset,xval,yval,zval @@ -506,7 +506,7 @@ program combine_AVS_DX iglobpointoffset = iglobpointoffset + npoin close(10) - if(ivalue == 2) close(12) + if (ivalue == 2) close(12) enddo enddo @@ -524,7 +524,7 @@ program combine_AVS_DX above_zero = 0 below_zero = 0 - if(USE_OPENDX) write(11,*) 'object 2 class array type int rank 1 shape 4 items ',ntotspecAVS_DX,' data follows' + if (USE_OPENDX) write(11,*) 'object 2 class array type int rank 1 shape 4 items ',ntotspecAVS_DX,' data follows' do iregion_code = region_min,region_max @@ -537,15 +537,15 @@ program combine_AVS_DX call create_serial_name_database(prname,iproc,iregion_code, & LOCAL_PATH,NPROCTOT,OUTPUT_FILES) - if(ivalue == 1) then + if (ivalue == 1) then open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementsfaces.txt',status='old',action='read') open(unit=12,file=prname(1:len_trim(prname))//'AVS_DXpointsfaces.txt',status='old',action='read') - else if(ivalue == 2) then + else if (ivalue == 2) then open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementschunks.txt',status='old',action='read') - if(icolor == 5 .or. icolor == 6) & + if (icolor == 5 .or. icolor == 6) & open(unit=13,file=prname(1:len_trim(prname))//'AVS_DXelementschunks_dvp_dvs.txt',status='old',action='read') open(unit=12,file=prname(1:len_trim(prname))//'AVS_DXpointschunks.txt',status='old',action='read') - else if(ivalue == 3) then + else if (ivalue == 3) then open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementssurface.txt',status='old',action='read') open(unit=12,file=prname(1:len_trim(prname))//'AVS_DXpointssurface.txt',status='old',action='read') endif @@ -558,26 +558,26 @@ program combine_AVS_DX ! read local elements in this slice and output global AVS or DX elements do ispec=1,nspec read(10,*) numelem,idoubling,iglob1,iglob2,iglob3,iglob4 - if(icolor == 5 .or. icolor == 6) then + if (icolor == 5 .or. icolor == 6) then read(13,*) numelem2,deltavp,deltavs dvp(numelem + iglobelemoffset) = deltavp dvs(numelem + iglobelemoffset) = deltavs else numelem2 = 0 endif - if(numelem /= ispec) stop 'incorrect element number' - if((icolor == 5 .or. icolor == 6) .and. numelem2 /= ispec) stop 'incorrect element number' + if (numelem /= ispec) stop 'incorrect element number' + if ((icolor == 5 .or. icolor == 6) .and. numelem2 /= ispec) stop 'incorrect element number' ! compute max of the doubling flag maxdoubling = max(maxdoubling,idoubling) ! assign material property (which can be filtered later in AVS_DX) - if(imaterial == 1) then + if (imaterial == 1) then imatprop = idoubling - else if(imaterial == 2) then + else if (imaterial == 2) then imatprop = iproc - else if(imaterial == 3) then + else if (imaterial == 3) then imatprop = iregion_code - else if(imaterial == 4) then + else if (imaterial == 4) then imatprop = ichunk_slice(iproc) else stop 'invalid code for material property' @@ -593,7 +593,7 @@ program combine_AVS_DX ! in the case of OpenDX, node numbers start at zero ! in the case of AVS, node numbers start at one - if(USE_OPENDX) then + if (USE_OPENDX) then ! point order in OpenDX is 1,4,2,3 *not* 1,2,3,4 as in AVS write(11,"(i6,1x,i6,1x,i6,1x,i6)") iglob1-1,iglob4-1,iglob2-1,iglob3-1 else @@ -605,7 +605,7 @@ program combine_AVS_DX NGLL_current_vert = NGLLZ ! check that the degree is not above the threshold for list of percentages - if(NGLL_current_horiz > NGLL_MAX_STABILITY .or. & + if (NGLL_current_horiz > NGLL_MAX_STABILITY .or. & NGLL_current_vert > NGLL_MAX_STABILITY) & stop 'degree too high to compute stability value' @@ -616,7 +616,7 @@ program combine_AVS_DX stabmax = -1.d0 gridmin = HUGEVAL - if(idoubling == IFLAG_CRUST) then + if (idoubling == IFLAG_CRUST) then ! distinguish between horizontal and vertical directions in crust ! because we have a different polynomial degree in each direction @@ -668,25 +668,25 @@ program combine_AVS_DX do istab = 1,4 do jstab = 1,4 - if(jstab /= istab) then + if (jstab /= istab) then - if(istab == 1) then + if (istab == 1) then ipointnumber1_vert = iglob1 - else if(istab == 2) then + else if (istab == 2) then ipointnumber1_vert = iglob2 - else if(istab == 3) then + else if (istab == 3) then ipointnumber1_vert = iglob3 - else if(istab == 4) then + else if (istab == 4) then ipointnumber1_vert = iglob4 endif - if(jstab == 1) then + if (jstab == 1) then ipointnumber2_vert = iglob1 - else if(jstab == 2) then + else if (jstab == 2) then ipointnumber2_vert = iglob2 - else if(jstab == 3) then + else if (jstab == 3) then ipointnumber2_vert = iglob3 - else if(jstab == 4) then + else if (jstab == 4) then ipointnumber2_vert = iglob4 endif @@ -724,13 +724,13 @@ program combine_AVS_DX ! if topography then subtract reference ellipsoid or sphere for color code ! if ellipticity then subtract reference sphere for color code ! otherwise subtract nothing - if(TOPOGRAPHY .or. CRUSTAL) then - if(ELLIPTICITY) then + if (TOPOGRAPHY .or. CRUSTAL) then + if (ELLIPTICITY) then reference = 1.d0 - (3.d0*dcos(theta_s)**2 - 1.d0)/3.d0/299.8d0 else reference = R_UNIT_SPHERE endif - else if(ELLIPTICITY) then + else if (ELLIPTICITY) then reference = R_UNIT_SPHERE else reference = 0. @@ -747,7 +747,7 @@ program combine_AVS_DX close(10) close(12) - if(icolor == 5 .or. icolor == 6) close(13) + if (icolor == 5 .or. icolor == 6) close(13) enddo enddo @@ -755,7 +755,7 @@ program combine_AVS_DX ! saturate color scale for elevation since small values ! apply non linear scaling if topography to enhance regions around sea level - if(TOPOGRAPHY .or. CRUSTAL) then + if (TOPOGRAPHY .or. CRUSTAL) then ! compute absolute maximum rnorm_factor = maxval(dabs(elevation_sphere(:))) @@ -771,15 +771,15 @@ program combine_AVS_DX ! compute total area consisting of oceans ! and suppress areas that are not considered oceans if needed ! use arbitrary threshold to suppress artefacts in ETOPO5 model - if(xval >= -0.018) then - if(OCEANS_ONLY) xval = 0. + if (xval >= -0.018) then + if (OCEANS_ONLY) xval = 0. above_zero = above_zero + 1 else below_zero = below_zero + 1 endif - if(xval >= 0.) then - if(.not. OCEANS_ONLY) then + if (xval >= 0.) then + if (.not. OCEANS_ONLY) then elevation_sphere(ispec_scale_AVS_DX) = xval ** SCALE_NON_LINEAR else elevation_sphere(ispec_scale_AVS_DX) = 0. @@ -797,7 +797,7 @@ program combine_AVS_DX endif - if(ISOTROPIC_3D_MANTLE) then + if (ISOTROPIC_3D_MANTLE) then ! compute absolute maximum for dvp rnorm_factor = maxval(dabs(dvp(:))) @@ -808,7 +808,7 @@ program combine_AVS_DX ! apply non-linear scaling do ispec_scale_AVS_DX = 1,ntotspecAVS_DX xval = dvp(ispec_scale_AVS_DX) - if(xval >= 0.) then + if (xval >= 0.) then dvp(ispec_scale_AVS_DX) = xval ** SCALE_NON_LINEAR else dvp(ispec_scale_AVS_DX) = - dabs(xval) ** SCALE_NON_LINEAR @@ -824,7 +824,7 @@ program combine_AVS_DX ! apply non-linear scaling do ispec_scale_AVS_DX = 1,ntotspecAVS_DX xval = dvs(ispec_scale_AVS_DX) - if(xval >= 0.) then + if (xval >= 0.) then dvs(ispec_scale_AVS_DX) = xval ** SCALE_NON_LINEAR else dvs(ispec_scale_AVS_DX) = - dabs(xval) ** SCALE_NON_LINEAR @@ -836,7 +836,7 @@ program combine_AVS_DX ! ************* generate element data values ****************** ! output AVS or DX header for data - if(USE_OPENDX) then + if (USE_OPENDX) then write(11,*) 'attribute "element type" string "quads"' write(11,*) 'attribute "ref" string "positions"' write(11,*) 'object 3 class array type float rank 0 items ',ntotspecAVS_DX,' data follows' @@ -859,11 +859,11 @@ program combine_AVS_DX call create_serial_name_database(prname,iproc,iregion_code, & LOCAL_PATH,NPROCTOT,OUTPUT_FILES) - if(ivalue == 1) then + if (ivalue == 1) then open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementsfaces.txt',status='old',action='read') - else if(ivalue == 2) then + else if (ivalue == 2) then open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementschunks.txt',status='old',action='read') - else if(ivalue == 3) then + else if (ivalue == 3) then open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementssurface.txt',status='old',action='read') endif @@ -873,36 +873,36 @@ program combine_AVS_DX ! read local elements in this slice and output global AVS or DX elements do ispec=1,nspec read(10,*) numelem,idoubling,iglob1,iglob2,iglob3,iglob4 - if(numelem /= ispec) stop 'incorrect element number' + if (numelem /= ispec) stop 'incorrect element number' ! data is either the slice number or the mesh doubling region flag - if(icolor == 1) then + if (icolor == 1) then val_color = dble(idoubling) - else if(icolor == 2) then + else if (icolor == 2) then val_color = dble(iproc) - else if(icolor == 3) then + else if (icolor == 3) then val_color = stability_value(numelem + iglobelemoffset) - else if(icolor == 4) then + else if (icolor == 4) then val_color = gridpoints_per_wavelength(numelem + iglobelemoffset) ! put a threshold for number of points per wavelength displayed ! otherwise the scale is too large and we cannot see the small values - if(val_color > THRESHOLD_GRIDPOINTS) then + if (val_color > THRESHOLD_GRIDPOINTS) then val_color = THRESHOLD_GRIDPOINTS threshold_used = .true. endif - else if(icolor == 5) then + else if (icolor == 5) then ! minus sign to get the color scheme right: blue is fast (+) and red is slow (-) val_color = -dvp(numelem + iglobelemoffset) - else if(icolor == 6) then + else if (icolor == 6) then ! minus sign to get the color scheme right: blue is fast (+) and red is slow (-) val_color = -dvs(numelem + iglobelemoffset) - else if(icolor == 7) then + else if (icolor == 7) then val_color = elevation_sphere(numelem + iglobelemoffset) - else if(icolor == 8) then + else if (icolor == 8) then val_color = iregion_code - else if(icolor == 9) then - if(idoubling == itarget_doubling) then + else if (icolor == 9) then + if (idoubling == itarget_doubling) then val_color = dble(iregion_code) else val_color = dble(IFLAG_DUMMY) @@ -912,7 +912,7 @@ program combine_AVS_DX endif ! write to AVS or DX global file with correct offset - if(USE_OPENDX) then + if (USE_OPENDX) then write(11,*) sngl(val_color) else write(11,*) numelem + iglobelemoffset,' ',sngl(val_color) @@ -927,7 +927,7 @@ program combine_AVS_DX enddo ! define OpenDX field - if(USE_OPENDX) then + if (USE_OPENDX) then write(11,*) 'attribute "dep" string "connections"' write(11,*) 'object "irregular positions irregular connections" class field' write(11,*) 'component "positions" value 1' @@ -944,7 +944,7 @@ program combine_AVS_DX ! print min and max of stability and points per lambda - if(ivalue == 2) then + if (ivalue == 2) then ! compute minimum and maximum of stability value and points per wavelength @@ -967,14 +967,14 @@ program combine_AVS_DX print *,'half duration of ',sngl(hdur),' s used for points per wavelength' print * - if(hdur < 5.*DT) then + if (hdur < 5.*DT) then print *,'***************************************************************' print *,'Source time function is a Heaviside, points per wavelength meaningless' print *,'***************************************************************' print * endif - if(icolor == 4 .and. threshold_used) then + if (icolor == 4 .and. threshold_used) then print *,'***************************************************************' print *,'the number of points per wavelength have been cut above a threshold' print *,'of ',THRESHOLD_GRIDPOINTS,' to avoid saturation of color scale' @@ -984,10 +984,10 @@ program combine_AVS_DX endif ! if we have the surface for the Earth, print min and max of elevation - if(ivalue == 3) then + if (ivalue == 3) then print * print *,'elevation min, max = ',minval(elevation_sphere),maxval(elevation_sphere) - if(TOPOGRAPHY .or. CRUSTAL) print *,'elevation has been normalized for topography' + if (TOPOGRAPHY .or. CRUSTAL) print *,'elevation has been normalized for topography' print * endif diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/compute_coordinates_grid.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/compute_coordinates_grid.f90 index 695a075a8..11a50372b 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/compute_coordinates_grid.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/compute_coordinates_grid.f90 @@ -70,7 +70,7 @@ subroutine compute_coord_main_mesh(offset_x,offset_y,offset_z,xelm,yelm,zelm, & ! loop on all the nodes in this element do ignod = 1,NGNOD - if(ilayer == NUMBER_OF_MESH_LAYERS .and. INCLUDE_CENTRAL_CUBE) then + if (ilayer == NUMBER_OF_MESH_LAYERS .and. INCLUDE_CENTRAL_CUBE) then ! case of the inner core ratio_xi = ((iproc_xi + offset_x(ignod)/dble(NEX_PER_PROC_XI))/dble(NPROC_XI)) fact_xi = 2.d0*ratio_xi-1.d0 @@ -235,7 +235,7 @@ subroutine compute_coord_main_mesh(offset_x,offset_y,offset_z,xelm,yelm,zelm, & end select ! rotate the chunk to the right location if we do not mesh the full Earth - if(NCHUNKS /= 6) then + if (NCHUNKS /= 6) then ! rotate bottom vector_ori(1) = x_bot @@ -275,7 +275,7 @@ subroutine compute_coord_main_mesh(offset_x,offset_y,offset_z,xelm,yelm,zelm, & endif enddo -! if(ilayer == NUMBER_OF_MESH_LAYERS .and. INCLUDE_CENTRAL_CUBE) write(IMAIN,*) +! if (ilayer == NUMBER_OF_MESH_LAYERS .and. INCLUDE_CENTRAL_CUBE) write(IMAIN,*) end subroutine compute_coord_main_mesh !--------------------------------------------------------------------------- @@ -305,7 +305,7 @@ subroutine compute_coord_central_cube(ix,iy,iz, & ratio_y = (dble(iproc_eta) + dble(iy)/dble(2*ny_central_cube)) / dble(NPROC_ETA) ratio_z = dble(iz)/dble(2*nz_central_cube) - if(abs(ratio_x) > 1.001d0 .or. abs(ratio_y) > 1.001d0 .or. abs(ratio_z) > 1.001d0) stop 'wrong ratio in central cube' + if (abs(ratio_x) > 1.001d0 .or. abs(ratio_y) > 1.001d0 .or. abs(ratio_z) > 1.001d0) stop 'wrong ratio in central cube' ! use a "flat" cubed sphere to create the central cube diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/compute_element_properties.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/compute_element_properties.f90 index ce136e5b8..a4e8b9bc8 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/compute_element_properties.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/compute_element_properties.f90 @@ -334,7 +334,7 @@ subroutine compute_element_properties(ispec,iregion_code,idoubling, & ! ************** ! add topography on the Moho *before* adding the 3D crustal model so that the streched ! mesh gets assigned the right model values - if(THREE_D_MODEL/=0 .and. (idoubling(ispec)==IFLAG_CRUST .or. idoubling(ispec)==IFLAG_220_80 & + if (THREE_D_MODEL/=0 .and. (idoubling(ispec)==IFLAG_CRUST .or. idoubling(ispec)==IFLAG_220_80 & .or. idoubling(ispec)==IFLAG_80_MOHO)) call moho_stretching(myrank,xelm,yelm,zelm,RMOHO,R220) ! compute values for the Earth model @@ -358,11 +358,11 @@ subroutine compute_element_properties(ispec,iregion_code,idoubling, & coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr) ! add topography without the crustal model - if(TOPOGRAPHY .and. (idoubling(ispec)==IFLAG_CRUST .or. idoubling(ispec)==IFLAG_220_80 & + if (TOPOGRAPHY .and. (idoubling(ispec)==IFLAG_CRUST .or. idoubling(ispec)==IFLAG_220_80 & .or. idoubling(ispec)==IFLAG_80_MOHO)) call add_topography(myrank,xelm,yelm,zelm,ibathy_topo,R220) ! add topography on 410 km and 650 km discontinuity in model S362ANI - if(THREE_D_MODEL == THREE_D_MODEL_S362ANI .or. THREE_D_MODEL == THREE_D_MODEL_S362WMANI & + if (THREE_D_MODEL == THREE_D_MODEL_S362ANI .or. THREE_D_MODEL == THREE_D_MODEL_S362WMANI & .or. THREE_D_MODEL == THREE_D_MODEL_S362ANI_PREM .or. THREE_D_MODEL == THREE_D_MODEL_S29EA) & call add_topography_410_650(myrank,xelm,yelm,zelm,R220,R400,R670,R771, & numker,numhpa,numcof,ihpa,lmax,nylm, & @@ -371,19 +371,19 @@ subroutine compute_element_properties(ispec,iregion_code,idoubling, & coe,ylmcof,wk1,wk2,wk3,varstr) ! CMB topography -! if(THREE_D_MODEL == THREE_D_MODEL_S362ANI .and. (idoubling(ispec)==IFLAG_MANTLE_NORMAL & +! if (THREE_D_MODEL == THREE_D_MODEL_S362ANI .and. (idoubling(ispec)==IFLAG_MANTLE_NORMAL & ! .or. idoubling(ispec)==IFLAG_OUTER_CORE_NORMAL)) & ! call add_topography_cmb(myrank,xelm,yelm,zelm,RTOPDDOUBLEPRIME,RCMB) ! ICB topography -! if(THREE_D_MODEL == THREE_D_MODEL_S362ANI .and. (idoubling(ispec)==IFLAG_OUTER_CORE_NORMAL & +! if (THREE_D_MODEL == THREE_D_MODEL_S362ANI .and. (idoubling(ispec)==IFLAG_OUTER_CORE_NORMAL & ! .or. idoubling(ispec)==IFLAG_INNER_CORE_NORMAL .or. idoubling(ispec)==IFLAG_MIDDLE_CENTRAL_CUBE & ! .or. idoubling(ispec)==IFLAG_BOTTOM_CENTRAL_CUBE .or. idoubling(ispec)==IFLAG_TOP_CENTRAL_CUBE & ! .or. idoubling(ispec)==IFLAG_IN_FICTITIOUS_CUBE)) & ! call add_topography_icb(myrank,xelm,yelm,zelm,RICB,RCMB) ! make the Earth elliptical - if(ELLIPTICITY) call get_ellipticity(xelm,yelm,zelm,nspl,rspl,espl,espl2) + if (ELLIPTICITY) call get_ellipticity(xelm,yelm,zelm,nspl,rspl,espl,espl2) ! recompute coordinates and jacobian for real 3-D model call calc_jacobian(myrank,xixstore,xiystore,xizstore, & diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/count_number_of_sources.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/count_number_of_sources.f90 index b8d9dd469..b04a2458e 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/count_number_of_sources.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/count_number_of_sources.f90 @@ -43,20 +43,20 @@ subroutine count_number_of_sources(NSOURCES) call get_value_string(CMTSOLUTION, 'solver.CMTSOLUTION', 'DATA/CMTSOLUTION') open(unit=1,file=CMTSOLUTION,iostat=ios,status='old',action='read') - if(ios /= 0) stop 'error opening CMTSOLUTION file' + if (ios /= 0) stop 'error opening CMTSOLUTION file' icounter = 0 do while(ios == 0) read(1,"(a)",iostat=ios) dummystring - if(ios == 0) icounter = icounter + 1 + if (ios == 0) icounter = icounter + 1 enddo close(1) - if(mod(icounter,NLINES_PER_CMTSOLUTION_SOURCE) /= 0) & + if (mod(icounter,NLINES_PER_CMTSOLUTION_SOURCE) /= 0) & stop 'total number of lines in CMTSOLUTION file should be a multiple of NLINES_PER_CMTSOLUTION_SOURCE' NSOURCES = icounter / NLINES_PER_CMTSOLUTION_SOURCE - if(NSOURCES < 1) stop 'need at least one source in CMTSOLUTION file' + if (NSOURCES < 1) stop 'need at least one source in CMTSOLUTION file' end subroutine count_number_of_sources diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/create_regions_mesh.F90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/create_regions_mesh.F90 index bd0d38990..2b16a67c7 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/create_regions_mesh.F90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/create_regions_mesh.F90 @@ -525,7 +525,7 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & call create_name_database(prname,myrank,iregion_code,LOCAL_PATH) ! Attenuation - if(ATTENUATION .and. ATTENUATION_3D) then + if (ATTENUATION .and. ATTENUATION_3D) then T_c_source = AM_V%QT_c_source tau_s(:) = AM_V%Qtau_s(:) allocate(Qmu_store(NGLLX,NGLLY,NGLLZ,nspec)) @@ -573,7 +573,7 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & allocate(eta_anisostore(NGLLX,NGLLY,NGLLZ,nspec)) ! Stacey - if(NCHUNKS /= 6) then + if (NCHUNKS /= 6) then nspec_stacey = nspec else nspec_stacey = 1 @@ -582,7 +582,7 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & allocate(rho_vs(NGLLX,NGLLY,NGLLZ,nspec_stacey)) nspec_ani = 1 - if((ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) .or. & + if ((ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) .or. & (ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE)) nspec_ani = nspec allocate(c11store(NGLLX,NGLLY,NGLLZ,nspec_ani)) @@ -651,9 +651,9 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA) ! if number of points is odd, the middle abscissa is exactly zero - if(mod(NGLLX,2) /= 0) xigll((NGLLX-1)/2+1) = ZERO - if(mod(NGLLY,2) /= 0) yigll((NGLLY-1)/2+1) = ZERO - if(mod(NGLLZ,2) /= 0) zigll((NGLLZ-1)/2+1) = ZERO + if (mod(NGLLX,2) /= 0) xigll((NGLLX-1)/2+1) = ZERO + if (mod(NGLLY,2) /= 0) yigll((NGLLY-1)/2+1) = ZERO + if (mod(NGLLZ,2) /= 0) zigll((NGLLZ-1)/2+1) = ZERO ! get the 3-D shape functions call get_shape3D(myrank,shape3D,dershape3D,xigll,yigll,zigll) @@ -665,13 +665,13 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & call get_shape2D(myrank,shape2D_top,dershape2D_top,xigll,yigll,NGLLX,NGLLY) ! define models 1066a and ak135 and ref - if(REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then + if (REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then call define_model_1066a(CRUSTAL, M1066a_V) - else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135) then + else if (REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135) then call define_model_ak135(CRUSTAL, Mak135_V) - else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then + else if (REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then call define_model_ref(Mref_V) - else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) then + else if (REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) then call define_model_sea1d(CRUSTAL, SEA1DM_V) endif @@ -696,15 +696,15 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & if (.not. ADD_4TH_DOUBLING) NUMBER_OF_MESH_LAYERS = NUMBER_OF_MESH_LAYERS - 1 ! define the first and last layers that define this region - if(iregion_code == IREGION_CRUST_MANTLE) then + if (iregion_code == IREGION_CRUST_MANTLE) then ifirst_region = 1 ilast_region = 10 + layer_shift - else if(iregion_code == IREGION_OUTER_CORE) then + else if (iregion_code == IREGION_OUTER_CORE) then ifirst_region = 11 + layer_shift ilast_region = NUMBER_OF_MESH_LAYERS - 1 - else if(iregion_code == IREGION_INNER_CORE) then + else if (iregion_code == IREGION_INNER_CORE) then ifirst_region = NUMBER_OF_MESH_LAYERS ilast_region = NUMBER_OF_MESH_LAYERS @@ -725,7 +725,7 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & endif allocate (perm_layer(ifirst_region:ilast_region)) perm_layer = (/ (i, i=ilast_region,ifirst_region,-1) /) -! if(iregion_code == IREGION_CRUST_MANTLE) then +! if (iregion_code == IREGION_CRUST_MANTLE) then ! cpt=3 ! perm_layer(1)=first_layer_aniso ! perm_layer(2)=last_layer_aniso @@ -744,7 +744,7 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & ystore(:,:,:,:) = 0.d0 zstore(:,:,:,:) = 0.d0 - if(ipass == 1) ibool(:,:,:,:) = 0 + if (ipass == 1) ibool(:,:,:,:) = 0 ! initialize boundary arrays iboun(:,:) = .false. @@ -753,33 +753,33 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & ! store and save the final arrays only in the second pass ! therefore in the first pass some arrays can be allocated with a dummy size - if(ipass == 1) then + if (ipass == 1) then ACTUALLY_STORE_ARRAYS = .false. - allocate(xixstore(NGLLX,NGLLY,NGLLZ,1),stat=ier); if(ier /= 0) stop 'error in allocate' - allocate(xiystore(NGLLX,NGLLY,NGLLZ,1),stat=ier); if(ier /= 0) stop 'error in allocate' - allocate(xizstore(NGLLX,NGLLY,NGLLZ,1),stat=ier); if(ier /= 0) stop 'error in allocate' - allocate(etaxstore(NGLLX,NGLLY,NGLLZ,1),stat=ier); if(ier /= 0) stop 'error in allocate' - allocate(etaystore(NGLLX,NGLLY,NGLLZ,1),stat=ier); if(ier /= 0) stop 'error in allocate' - allocate(etazstore(NGLLX,NGLLY,NGLLZ,1),stat=ier); if(ier /= 0) stop 'error in allocate' - allocate(gammaxstore(NGLLX,NGLLY,NGLLZ,1),stat=ier); if(ier /= 0) stop 'error in allocate' - allocate(gammaystore(NGLLX,NGLLY,NGLLZ,1),stat=ier); if(ier /= 0) stop 'error in allocate' - allocate(gammazstore(NGLLX,NGLLY,NGLLZ,1),stat=ier); if(ier /= 0) stop 'error in allocate' + allocate(xixstore(NGLLX,NGLLY,NGLLZ,1),stat=ier); if (ier /= 0) stop 'error in allocate' + allocate(xiystore(NGLLX,NGLLY,NGLLZ,1),stat=ier); if (ier /= 0) stop 'error in allocate' + allocate(xizstore(NGLLX,NGLLY,NGLLZ,1),stat=ier); if (ier /= 0) stop 'error in allocate' + allocate(etaxstore(NGLLX,NGLLY,NGLLZ,1),stat=ier); if (ier /= 0) stop 'error in allocate' + allocate(etaystore(NGLLX,NGLLY,NGLLZ,1),stat=ier); if (ier /= 0) stop 'error in allocate' + allocate(etazstore(NGLLX,NGLLY,NGLLZ,1),stat=ier); if (ier /= 0) stop 'error in allocate' + allocate(gammaxstore(NGLLX,NGLLY,NGLLZ,1),stat=ier); if (ier /= 0) stop 'error in allocate' + allocate(gammaystore(NGLLX,NGLLY,NGLLZ,1),stat=ier); if (ier /= 0) stop 'error in allocate' + allocate(gammazstore(NGLLX,NGLLY,NGLLZ,1),stat=ier); if (ier /= 0) stop 'error in allocate' else ACTUALLY_STORE_ARRAYS = .true. - allocate(xixstore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if(ier /= 0) stop 'error in allocate' - allocate(xiystore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if(ier /= 0) stop 'error in allocate' - allocate(xizstore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if(ier /= 0) stop 'error in allocate' - allocate(etaxstore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if(ier /= 0) stop 'error in allocate' - allocate(etaystore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if(ier /= 0) stop 'error in allocate' - allocate(etazstore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if(ier /= 0) stop 'error in allocate' - allocate(gammaxstore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if(ier /= 0) stop 'error in allocate' - allocate(gammaystore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if(ier /= 0) stop 'error in allocate' - allocate(gammazstore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if(ier /= 0) stop 'error in allocate' + allocate(xixstore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if (ier /= 0) stop 'error in allocate' + allocate(xiystore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if (ier /= 0) stop 'error in allocate' + allocate(xizstore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if (ier /= 0) stop 'error in allocate' + allocate(etaxstore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if (ier /= 0) stop 'error in allocate' + allocate(etaystore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if (ier /= 0) stop 'error in allocate' + allocate(etazstore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if (ier /= 0) stop 'error in allocate' + allocate(gammaxstore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if (ier /= 0) stop 'error in allocate' + allocate(gammaystore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if (ier /= 0) stop 'error in allocate' + allocate(gammazstore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if (ier /= 0) stop 'error in allocate' endif @@ -800,10 +800,10 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & rmin = rmins(ilayer) rmax = rmaxs(ilayer) - if(iregion_code == IREGION_CRUST_MANTLE .and. ilayer_loop==3) then + if (iregion_code == IREGION_CRUST_MANTLE .and. ilayer_loop==3) then FIRST_ELT_NON_ANISO = ispec+1 endif - if(iregion_code == IREGION_CRUST_MANTLE .and. ilayer_loop==(ilast_region-nb_layer_above_aniso+1)) then + if (iregion_code == IREGION_CRUST_MANTLE .and. ilayer_loop==(ilast_region-nb_layer_above_aniso+1)) then FIRST_ELT_ABOVE_ANISO = ispec+1 endif @@ -812,7 +812,7 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & ! if there is a doubling at the top of this region, we implement it in the last two layers of elements ! and therefore we suppress two layers of regular elements here USE_ONE_LAYER_SB = .false. - if(this_region_has_a_doubling(ilayer)) then + if (this_region_has_a_doubling(ilayer)) then if (ner(ilayer) == 1) then ner_without_doubling = ner_without_doubling - 1 USE_ONE_LAYER_SB = .true. @@ -863,7 +863,7 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & endif ! add one spectral element to the list ispec = ispec + 1 - if(ispec > nspec) call exit_MPI(myrank,'ispec greater than nspec in mesh creation') + if (ispec > nspec) call exit_MPI(myrank,'ispec greater than nspec in mesh creation') ! new get_flag_boundaries ! xmin & xmax @@ -928,14 +928,14 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & ! We have imposed that NEX be a multiple of 16 therefore we know that we can always create ! these 2 x 2 blocks because NEX_PER_PROC_XI / ratio_sampling_array(ilayer) and ! NEX_PER_PROC_ETA / ratio_sampling_array(ilayer) are always divisible by 2. - if(this_region_has_a_doubling(ilayer)) then + if (this_region_has_a_doubling(ilayer)) then if (USE_ONE_LAYER_SB) then call define_superbrick_one_layer(x_superbrick,y_superbrick,z_superbrick,ibool_superbrick,iboun_sb) nspec_sb = NSPEC_SUPERBRICK_1L iz_elem = ner(ilayer) step_mult = 2 else - if(iregion_code==IREGION_OUTER_CORE .and. ilayer==ilast_region .and. (CUT_SUPERBRICK_XI .or. CUT_SUPERBRICK_ETA)) then + if (iregion_code==IREGION_OUTER_CORE .and. ilayer==ilast_region .and. (CUT_SUPERBRICK_XI .or. CUT_SUPERBRICK_ETA)) then nspec_sb = NSPEC_DOUBLING_BASICBRICK step_mult = 1 else @@ -1040,7 +1040,7 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & ! add one spectral element to the list ispec = ispec + 1 - if(ispec > nspec) call exit_MPI(myrank,'ispec greater than nspec in mesh creation') + if (ispec > nspec) call exit_MPI(myrank,'ispec greater than nspec in mesh creation') ! new get_flag_boundaries ! xmin & xmax @@ -1108,7 +1108,7 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & ! define central cube in inner core - if(INCLUDE_CENTRAL_CUBE .and. iregion_code == IREGION_INNER_CORE) then + if (INCLUDE_CENTRAL_CUBE .and. iregion_code == IREGION_INNER_CORE) then ! create the shape of a regular mesh element in the inner core call hex_nodes(iaddx,iaddy,iaddz) @@ -1139,32 +1139,32 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & xgrid_central_cube,ygrid_central_cube,zgrid_central_cube, & iproc_xi,iproc_eta,NPROC_XI,NPROC_ETA,nx_central_cube,ny_central_cube,nz_central_cube,radius_cube) - if(ichunk == CHUNK_AB) then + if (ichunk == CHUNK_AB) then xelm(ia) = - ygrid_central_cube yelm(ia) = + xgrid_central_cube zelm(ia) = + zgrid_central_cube - else if(ichunk == CHUNK_AB_ANTIPODE) then + else if (ichunk == CHUNK_AB_ANTIPODE) then xelm(ia) = - ygrid_central_cube yelm(ia) = - xgrid_central_cube zelm(ia) = - zgrid_central_cube - else if(ichunk == CHUNK_AC) then + else if (ichunk == CHUNK_AC) then xelm(ia) = - ygrid_central_cube yelm(ia) = - zgrid_central_cube zelm(ia) = + xgrid_central_cube - else if(ichunk == CHUNK_AC_ANTIPODE) then + else if (ichunk == CHUNK_AC_ANTIPODE) then xelm(ia) = - ygrid_central_cube yelm(ia) = + zgrid_central_cube zelm(ia) = - xgrid_central_cube - else if(ichunk == CHUNK_BC) then + else if (ichunk == CHUNK_BC) then xelm(ia) = - zgrid_central_cube yelm(ia) = + ygrid_central_cube zelm(ia) = + xgrid_central_cube - else if(ichunk == CHUNK_BC_ANTIPODE) then + else if (ichunk == CHUNK_BC_ANTIPODE) then xelm(ia) = + zgrid_central_cube yelm(ia) = - ygrid_central_cube zelm(ia) = + xgrid_central_cube @@ -1177,7 +1177,7 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & ! add one spectral element to the list ispec = ispec + 1 - if(ispec > nspec) call exit_MPI(myrank,'ispec greater than nspec in central cube creation') + if (ispec > nspec) call exit_MPI(myrank,'ispec greater than nspec in central cube creation') ! new get_flag_boundaries ! xmin & xmax @@ -1214,10 +1214,10 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & nz_inf_limit = nz_central_cube endif - if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then - if(iz == nz_inf_limit) then + if (ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then + if (iz == nz_inf_limit) then idoubling(ispec) = IFLAG_BOTTOM_CENTRAL_CUBE - else if(iz == 2*nz_central_cube-2) then + else if (iz == 2*nz_central_cube-2) then idoubling(ispec) = IFLAG_TOP_CENTRAL_CUBE else if (iz > nz_inf_limit .and. iz < 2*nz_central_cube-2) then idoubling(ispec) = IFLAG_MIDDLE_CENTRAL_CUBE @@ -1257,17 +1257,17 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & !--- ! check total number of spectral elements created - if(ispec /= nspec) call exit_MPI(myrank,'ispec should equal nspec') + if (ispec /= nspec) call exit_MPI(myrank,'ispec should equal nspec') ! only create global addressing and the MPI buffers in the first pass - if(ipass == 1) then + if (ipass == 1) then ! allocate memory for arrays - allocate(locval(npointot),stat=ier); if(ier /= 0) stop 'error in allocate' - allocate(ifseg(npointot),stat=ier); if(ier /= 0) stop 'error in allocate' - allocate(xp(npointot),stat=ier); if(ier /= 0) stop 'error in allocate' - allocate(yp(npointot),stat=ier); if(ier /= 0) stop 'error in allocate' - allocate(zp(npointot),stat=ier); if(ier /= 0) stop 'error in allocate' + allocate(locval(npointot),stat=ier); if (ier /= 0) stop 'error in allocate' + allocate(ifseg(npointot),stat=ier); if (ier /= 0) stop 'error in allocate' + allocate(xp(npointot),stat=ier); if (ier /= 0) stop 'error in allocate' + allocate(yp(npointot),stat=ier); if (ier /= 0) stop 'error in allocate' + allocate(zp(npointot),stat=ier); if (ier /= 0) stop 'error in allocate' locval = 0 ifseg = .false. @@ -1294,23 +1294,23 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & call get_global(npointot,xp,yp,zp,ibool,locval,ifseg,nglob) - deallocate(xp,stat=ier); if(ier /= 0) stop 'error in deallocate' - deallocate(yp,stat=ier); if(ier /= 0) stop 'error in deallocate' - deallocate(zp,stat=ier); if(ier /= 0) stop 'error in deallocate' + deallocate(xp,stat=ier); if (ier /= 0) stop 'error in deallocate' + deallocate(yp,stat=ier); if (ier /= 0) stop 'error in deallocate' + deallocate(zp,stat=ier); if (ier /= 0) stop 'error in deallocate' ! check that number of points found equals theoretical value - if(nglob /= nglob_theor) then + if (nglob /= nglob_theor) then write(errmsg,*) 'incorrect total number of points found: myrank,nglob,nglob_theor,ipass,iregion_code = ',& myrank,nglob,nglob_theor,ipass,iregion_code call exit_MPI(myrank,errmsg) endif - if(minval(ibool) /= 1 .or. maxval(ibool) /= nglob_theor) call exit_MPI(myrank,'incorrect global numbering') + if (minval(ibool) /= 1 .or. maxval(ibool) /= nglob_theor) call exit_MPI(myrank,'incorrect global numbering') ! create a new indirect addressing to reduce cache misses in memory access in the solver ! this is *critical* to improve performance in the solver - allocate(copy_ibool_ori(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if(ier /= 0) stop 'error in allocate' - allocate(mask_ibool(nglob),stat=ier); if(ier /= 0) stop 'error in allocate' + allocate(copy_ibool_ori(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if (ier /= 0) stop 'error in allocate' + allocate(mask_ibool(nglob),stat=ier); if (ier /= 0) stop 'error in allocate' mask_ibool(:) = -1 copy_ibool_ori(:,:,:,:) = ibool(:,:,:,:) @@ -1320,7 +1320,7 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & do k=1,NGLLZ do j=1,NGLLY do i=1,NGLLX - if(mask_ibool(copy_ibool_ori(i,j,k,ispec)) == -1) then + if (mask_ibool(copy_ibool_ori(i,j,k,ispec)) == -1) then ! create a new point inumber = inumber + 1 ibool(i,j,k,ispec) = inumber @@ -1334,12 +1334,12 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & enddo enddo - deallocate(copy_ibool_ori,stat=ier); if(ier /= 0) stop 'error in deallocate' - deallocate(mask_ibool,stat=ier); if(ier /= 0) stop 'error in deallocate' + deallocate(copy_ibool_ori,stat=ier); if (ier /= 0) stop 'error in deallocate' + deallocate(mask_ibool,stat=ier); if (ier /= 0) stop 'error in deallocate' - if(minval(ibool) /= 1 .or. maxval(ibool) /= nglob_theor) call exit_MPI(myrank,'incorrect global numbering after sorting') + if (minval(ibool) /= 1 .or. maxval(ibool) /= nglob_theor) call exit_MPI(myrank,'incorrect global numbering after sorting') - allocate(mask_ibool2(nglob),stat=ier); if(ier /= 0) stop 'error in allocate' + allocate(mask_ibool2(nglob),stat=ier); if (ier /= 0) stop 'error in allocate' mask_ibool2(:) = .false. ! create MPI buffers ! arrays locval(npointot) and ifseg(npointot) used to save memory @@ -1363,7 +1363,7 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & do k = 1,NGLLZ,NGLLZ-1 do j = 1,NGLLY,NGLLY-1 do i = 1,NGLLX,NGLLX-1 - if(mask_ibool2(ibool(i,j,k,ispec))) then + if (mask_ibool2(ibool(i,j,k,ispec))) then is_on_a_slice_edge(ispec) = .true. goto 888 endif @@ -1374,13 +1374,13 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & enddo ! Stacey - if(NCHUNKS /= 6) & + if (NCHUNKS /= 6) & !!!!!!!! call get_absorb(myrank,prname,iboun,nspec,nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, & call get_absorb(myrank,iboun,nspec,nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, & NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM) ! create AVS or DX mesh data for the slices - if(SAVE_MESH_FILES) then + if (SAVE_MESH_FILES) then call write_AVS_DX_global_data(myrank,prname,nspec,ibool,idoubling,xstore,ystore,zstore,locval,ifseg,npointot) call write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool, & idoubling,xstore,ystore,zstore,locval,ifseg,npointot) @@ -1394,12 +1394,12 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & idoubling,xstore,ystore,zstore,locval,ifseg,npointot) endif - deallocate(locval,stat=ier); if(ier /= 0) stop 'error in deallocate' - deallocate(ifseg,stat=ier); if(ier /= 0) stop 'error in deallocate' - deallocate(mask_ibool2,stat=ier); if(ier /= 0) stop 'error in deallocate' + deallocate(locval,stat=ier); if (ier /= 0) stop 'error in deallocate' + deallocate(ifseg,stat=ier); if (ier /= 0) stop 'error in deallocate' + deallocate(mask_ibool2,stat=ier); if (ier /= 0) stop 'error in deallocate' ! only create mass matrix and save all the final arrays in the second pass - else if(ipass == 2) then + else if (ipass == 2) then ! copy the theoretical number of points for the second pass nglob = nglob_theor @@ -1410,7 +1410,7 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & !!!! DM DM detection of the edges, coloring and permutation separately allocate(perm(nspec)) - if(USE_MESH_COLORING_INNER_OUTER) then + if (USE_MESH_COLORING_INNER_OUTER) then stop 'USE_MESH_COLORING_INNER_OUTER should not be used in the serial case' @@ -1422,13 +1422,13 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & !! DK DK for regular C version for CPUs: do not use colors but nonetheless put all the outer elements !! DK DK first in order to be able to overlap non-blocking MPI communications with calculations -! if(USE_REGULAR_C_CPU_VERSION) then +! if (USE_REGULAR_C_CPU_VERSION) then ! inumber_in_new_list_after_perm = 0 ! first detect and list all the outer elements ! do ispec = 1,nspec -! if(is_on_a_slice_edge(ispec)) then +! if (is_on_a_slice_edge(ispec)) then ! inumber_in_new_list_after_perm = inumber_in_new_list_after_perm + 1 ! perm(ispec) = inumber_in_new_list_after_perm ! endif @@ -1442,7 +1442,7 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & ! nspec_outer_min_global = inumber_in_new_list_after_perm ! nspec_outer_max_global = inumber_in_new_list_after_perm !#endif -! if(myrank == 0) then +! if (myrank == 0) then ! open(unit=99,file='../DATABASES_FOR_SOLVER/values_from_mesher_nspec_outer.h',status='unknown') ! write(99,*) '#define NSPEC_OUTER ',nspec_outer_max_global ! write(99,*) '// NSPEC_OUTER_min = ',nspec_outer_min_global @@ -1451,18 +1451,18 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & ! endif ! just in case, test that we have detected outer elements -! if(inumber_in_new_list_after_perm <= 0) stop 'fatal error: no outer elements detected!' +! if (inumber_in_new_list_after_perm <= 0) stop 'fatal error: no outer elements detected!' ! then detect and list all the inner elements ! do ispec = 1,nspec -! if(.not. is_on_a_slice_edge(ispec)) then +! if (.not. is_on_a_slice_edge(ispec)) then ! inumber_in_new_list_after_perm = inumber_in_new_list_after_perm + 1 ! perm(ispec) = inumber_in_new_list_after_perm ! endif ! enddo ! test that all the elements have been used once and only once -! if(inumber_in_new_list_after_perm /= nspec) stop 'fatal error: inumber_in_new_list_after_perm not equal to nspec' +! if (inumber_in_new_list_after_perm /= nspec) stop 'fatal error: inumber_in_new_list_after_perm not equal to nspec' ! else @@ -1503,7 +1503,7 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & ! check that the sum of all the numbers of elements found in each color is equal ! to the total number of elements in the mesh - if(sum(number_of_elements_in_this_color) /= nspec) then + if (sum(number_of_elements_in_this_color) /= nspec) then print *,'nspec = ',nspec print *,'total number of elements in all the colors of the mesh = ',sum(number_of_elements_in_this_color) stop 'incorrect total number of elements in all the colors of the mesh' @@ -1511,7 +1511,7 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & ! check that the sum of all the numbers of elements found in each color for the outer elements is equal ! to the total number of outer elements found in the mesh - if(sum(number_of_elements_in_this_color(1:nb_colors_outer_elements)) /= nspec_outer) then + if (sum(number_of_elements_in_this_color(1:nb_colors_outer_elements)) /= nspec_outer) then print *,'nspec_outer = ',nspec_outer print *,'total number of elements in all the colors of the mesh for outer elements = ',sum(number_of_elements_in_this_color) stop 'incorrect total number of elements in all the colors of the mesh for outer elements' @@ -1525,7 +1525,7 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & nspec_outer_min_global = nspec_outer nspec_outer_max_global = nspec_outer #endif - if(myrank == 0) then + if (myrank == 0) then open(unit=99,file='../DATABASES_FOR_SOLVER/values_from_mesher_nspec_outer.h',status='unknown') write(99,*) '#define NSPEC_OUTER ',nspec_outer_max_global write(99,*) '// NSPEC_OUTER_min = ',nspec_outer_min_global @@ -1655,14 +1655,14 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & ! NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX) ! creating mass matrix in this slice (will be fully assembled in the solver) - allocate(rmass(nglob),stat=ier); if(ier /= 0) stop 'error in allocate' + allocate(rmass(nglob),stat=ier); if (ier /= 0) stop 'error in allocate' rmass(:) = 0._CUSTOM_REAL do ispec=1,nspec ! suppress fictitious elements in central cube - if(idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle + if (idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle do k = 1,NGLLZ do j = 1,NGLLY @@ -1687,10 +1687,10 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & + xizl*(etaxl*gammayl-etayl*gammaxl)) ! definition depends if region is fluid or solid - if(iregion_code == IREGION_CRUST_MANTLE .or. iregion_code == IREGION_INNER_CORE) then + if (iregion_code == IREGION_CRUST_MANTLE .or. iregion_code == IREGION_INNER_CORE) then ! distinguish between single and double precision for reals - if(CUSTOM_REAL == SIZE_REAL) then + if (CUSTOM_REAL == SIZE_REAL) then rmass(iglobnum) = rmass(iglobnum) + & sngl(dble(rhostore(i,j,k,ispec)) * dble(jacobianl) * weight) else @@ -1698,12 +1698,12 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & endif ! fluid in outer core - else if(iregion_code == IREGION_OUTER_CORE) then + else if (iregion_code == IREGION_OUTER_CORE) then ! no anisotropy in the fluid, use kappav ! distinguish between single and double precision for reals - if(CUSTOM_REAL == SIZE_REAL) then + if (CUSTOM_REAL == SIZE_REAL) then rmass(iglobnum) = rmass(iglobnum) + & sngl(dble(jacobianl) * weight * dble(rhostore(i,j,k,ispec)) / dble(kappavstore(i,j,k,ispec))) else @@ -1722,7 +1722,7 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & ! save the binary files ! save ocean load mass matrix as well if oceans - if(OCEANS .and. iregion_code == IREGION_CRUST_MANTLE) then + if (OCEANS .and. iregion_code == IREGION_CRUST_MANTLE) then ! adding ocean load mass matrix at the top of the crust for oceans nglob_oceans = nglob @@ -1745,7 +1745,7 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & iglobnum=ibool(ix_oceans,iy_oceans,iz_oceans,ispec_oceans) ! compute local height of oceans - if(ISOTROPIC_3D_MANTLE) then + if (ISOTROPIC_3D_MANTLE) then ! get coordinates of current point xval = xstore(ix_oceans,iy_oceans,iz_oceans,ispec_oceans) @@ -1769,7 +1769,7 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & ! non-dimensionalize the elevation, which is in meters ! and suppress positive elevation, which means no oceans - if(elevation >= - MINIMUM_THICKNESS_3D_OCEANS) then + if (elevation >= - MINIMUM_THICKNESS_3D_OCEANS) then height_oceans = 0.d0 else height_oceans = dabs(elevation) / R_EARTH @@ -1784,7 +1784,7 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & * dble(RHO_OCEANS) * height_oceans ! distinguish between single and double precision for reals - if(CUSTOM_REAL == SIZE_REAL) then + if (CUSTOM_REAL == SIZE_REAL) then rmass_ocean_load(iglobnum) = rmass_ocean_load(iglobnum) + sngl(weight) else rmass_ocean_load(iglobnum) = rmass_ocean_load(iglobnum) + weight @@ -1811,8 +1811,8 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & gammaxstore,gammaystore,gammazstore, & kappavstore,muvstore,ibool,rmass,nspec,nglob,myrank,NPROCTOT,xstore,ystore,zstore) - deallocate(rmass,stat=ier); if(ier /= 0) stop 'error in deallocate' - deallocate(rmass_ocean_load,stat=ier); if(ier /= 0) stop 'error in deallocate' + deallocate(rmass,stat=ier); if (ier /= 0) stop 'error in deallocate' + deallocate(rmass_ocean_load,stat=ier); if (ier /= 0) stop 'error in deallocate' ! compute volume, bottom and top area of that part of the slice volume_local = ZERO @@ -1852,9 +1852,9 @@ subroutine create_regions_mesh(iregion_code,ibool,idoubling, & endif ! end of test if first or second pass ! deallocate these arrays after each pass because they have a different size in each pass to save memory - deallocate(xixstore,xiystore,xizstore,stat=ier); if(ier /= 0) stop 'error in deallocate' - deallocate(etaxstore,etaystore,etazstore,stat=ier); if(ier /= 0) stop 'error in deallocate' - deallocate(gammaxstore,gammaystore,gammazstore,stat=ier); if(ier /= 0) stop 'error in deallocate' + deallocate(xixstore,xiystore,xizstore,stat=ier); if (ier /= 0) stop 'error in deallocate' + deallocate(etaxstore,etaystore,etazstore,stat=ier); if (ier /= 0) stop 'error in deallocate' + deallocate(gammaxstore,gammaystore,gammazstore,stat=ier); if (ier /= 0) stop 'error in deallocate' ! deallocate arrays deallocate(rhostore,kappavstore,kappahstore) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/create_serial_name_database.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/create_serial_name_database.f90 index 7bc47dbb3..8cb6b14ac 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/create_serial_name_database.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/create_serial_name_database.f90 @@ -47,7 +47,7 @@ subroutine create_serial_name_database(prname,iproc,iregion_code, & write(procname,"('/proc',i6.6,'_reg',i1,'_')") iproc,iregion_code ! on a machine with local disks, path on frontend can be different from local paths - if(.not. LOCAL_PATH_IS_ALSO_GLOBAL) then + if (.not. LOCAL_PATH_IS_ALSO_GLOBAL) then ! allocate array for active processors allocate(num_active_proc(0:NPROCTOT-1)) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/crustal_model.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/crustal_model.f90 index acf98912c..da0d3e0bc 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/crustal_model.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/crustal_model.f90 @@ -67,23 +67,23 @@ subroutine crustal_model(lat,lon,x,vp,vs,rho,moho,found_crust,CM_V) x7 = (R_EARTH-(h_uc+thicks(6)+thicks(7))*1000.0d0)/R_EARTH found_crust = .true. - if(x > x3 .and. INCLUDE_SEDIMENTS_CRUST) then + if (x > x3 .and. INCLUDE_SEDIMENTS_CRUST) then vp = vps(3) vs = vss(3) rho = rhos(3) - else if(x > x4 .and. INCLUDE_SEDIMENTS_CRUST) then + else if (x > x4 .and. INCLUDE_SEDIMENTS_CRUST) then vp = vps(4) vs = vss(4) rho = rhos(4) - else if(x > x5) then + else if (x > x5) then vp = vps(5) vs = vss(5) rho = rhos(5) - else if(x > x6) then + else if (x > x6) then vp = vps(6) vs = vss(6) rho = rhos(6) - else if(x > x7) then + else if (x > x7) then vp = vps(7) vs = vss(7) rho = rhos(7) @@ -150,12 +150,12 @@ subroutine read_crustal_model(CM_V) read (1,*) (CM_V%velocs(ikey,i),i=1,NLAYERS_CRUST) read (1,*) (CM_V%dens(ikey,i),i=1,NLAYERS_CRUST) read (1,*) (CM_V%thlr(ikey,i),i=1,NLAYERS_CRUST-1),CM_V%thlr(ikey,NLAYERS_CRUST) - if(CM_V%thlr(ikey,NLAYERS_CRUST) > h_moho_max) h_moho_max=CM_V%thlr(ikey,NLAYERS_CRUST) - if(CM_V%thlr(ikey,NLAYERS_CRUST) < h_moho_min) h_moho_min=CM_V%thlr(ikey,NLAYERS_CRUST) + if (CM_V%thlr(ikey,NLAYERS_CRUST) > h_moho_max) h_moho_max=CM_V%thlr(ikey,NLAYERS_CRUST) + if (CM_V%thlr(ikey,NLAYERS_CRUST) < h_moho_min) h_moho_min=CM_V%thlr(ikey,NLAYERS_CRUST) enddo close(1) - if(h_moho_min == HUGEVAL .or. h_moho_max == -HUGEVAL) & + if (h_moho_min == HUGEVAL .or. h_moho_max == -HUGEVAL) & stop 'incorrect moho depths in read_3D_crustal_model' end subroutine read_crustal_model @@ -195,12 +195,12 @@ subroutine crust(lat,lon,velp,vels,rho,thick,abbreviation,code,thlr,velocp,veloc ! get integer colatitude and longitude of crustal cap ! -90 90.0d0 .or. lat < -90.0d0 .or. lon > 180.0d0 .or. lon < -180.0d0) & + if (lat > 90.0d0 .or. lat < -90.0d0 .or. lon > 180.0d0 .or. lon < -180.0d0) & stop 'error in latitude/longitude range in crust' - if(lat==90.0d0) lat=89.9999d0 - if(lat==-90.0d0) lat=-89.9999d0 - if(lon==180.0d0) lon=179.9999d0 - if(lon==-180.0d0) lon=-179.9999d0 + if (lat==90.0d0) lat=89.9999d0 + if (lat==-90.0d0) lat=-89.9999d0 + if (lon==180.0d0) lon=179.9999d0 + if (lon==-180.0d0) lon=-179.9999d0 call icolat_ilon(lat,lon,icolat,ilon) crustaltype=abbreviation(icolat,ilon) @@ -270,13 +270,13 @@ subroutine crust(lat,lon,velp,vels,rho,thick,abbreviation,code,thlr,velocp,veloc call reduce(theta_rot,phi_rot) xlat(i) = (PI/2.0-theta_rot)*180.0/PI xlon(i) = phi_rot*180.0/PI - if(xlon(i) > 180.0) xlon(i) = xlon(i)-360.0 + if (xlon(i) > 180.0) xlon(i) = xlon(i)-360.0 enddo enddo - if(abs(total-1.0) > 0.001) stop 'error in cap integration for crust2.0' + if (abs(total-1.0) > 0.001) stop 'error in cap integration for crust2.0' npoints = i @@ -292,7 +292,7 @@ subroutine crust(lat,lon,velp,vels,rho,thick,abbreviation,code,thlr,velocp,veloc crustaltype=abbreviation(icolat,ilon) call get_crust_structure(crustaltype,velpl,velsl,rhol,thickl, & code,thlr,velocp,velocs,dens,ierr) - if(ierr /= 0) stop 'error in routine get_crust_structure' + if (ierr /= 0) stop 'error in routine get_crust_structure' do j=1,NLAYERS_CRUST rho(j)=rho(j)+weight(i)*rhol(j) thick(j)=thick(j)+weight(i)*thickl(j) @@ -314,15 +314,15 @@ subroutine icolat_ilon(xlat,xlon,icolat,ilon) double precision xlat,xlon integer icolat,ilon - if(xlat > 90.0d0 .or. xlat < -90.0d0 .or. xlon > 180.0d0 .or. xlon < -180.0d0) & + if (xlat > 90.0d0 .or. xlat < -90.0d0 .or. xlon > 180.0d0 .or. xlon < -180.0d0) & stop 'error in latitude/longitude range in icolat_ilon' icolat=int(1+((90.d0-xlat)/2.d0)) - if(icolat == 91) icolat=90 + if (icolat == 91) icolat=90 ilon=int(1+((180.d0+xlon)/2.d0)) - if(ilon == 181) ilon=1 + if (ilon == 181) ilon=1 - if(icolat>90 .or. icolat<1) stop 'error in routine icolat_ilon' - if(ilon<1 .or. ilon>180) stop 'error in routine icolat_ilon' + if (icolat>90 .or. icolat<1) stop 'error in routine icolat_ilon' + if (ilon<1 .or. ilon>180) stop 'error in routine icolat_ilon' end subroutine icolat_ilon diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/define_derivation_matrices.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/define_derivation_matrices.f90 index be9391345..6c7e411fe 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/define_derivation_matrices.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/define_derivation_matrices.f90 @@ -63,12 +63,12 @@ subroutine define_derivation_matrices(xigll,yigll,zigll,wxgll,wygll,wzgll, & call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA) ! if number of points is odd, the middle abscissa is exactly ZERO - if(mod(NGLLX,2) /= 0) xigll((NGLLX-1)/2+1) = ZERO - if(mod(NGLLY,2) /= 0) yigll((NGLLY-1)/2+1) = ZERO - if(mod(NGLLZ,2) /= 0) zigll((NGLLZ-1)/2+1) = ZERO + if (mod(NGLLX,2) /= 0) xigll((NGLLX-1)/2+1) = ZERO + if (mod(NGLLY,2) /= 0) yigll((NGLLY-1)/2+1) = ZERO + if (mod(NGLLZ,2) /= 0) zigll((NGLLZ-1)/2+1) = ZERO ! distinguish between single and double precision for reals - if(CUSTOM_REAL == SIZE_REAL) then + if (CUSTOM_REAL == SIZE_REAL) then ! calculate derivatives of the Lagrange polynomials ! and precalculate some products in double precision diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/exit_mpi.F90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/exit_mpi.F90 index a19aab022..a377e340f 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/exit_mpi.F90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/exit_mpi.F90 @@ -64,7 +64,7 @@ subroutine exit_MPI(myrank,error_msg) close(IERROR) ! close output file - if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) close(IMAIN) + if (myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) close(IMAIN) ! stop all the MPI processes, and exit #ifdef USE_MPI diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_MPI_1D_buffers.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_MPI_1D_buffers.f90 index b5019fb04..9b63d2cd0 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_MPI_1D_buffers.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_MPI_1D_buffers.f90 @@ -85,19 +85,19 @@ subroutine get_MPI_1D_buffers(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool, do ispec=1,nspec ! remove central cube for chunk buffers - if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. & + if (idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. & idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. & idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. & idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle ! corner detection here - if(iMPIcut_xi(1,ispec) .and. iMPIcut_eta(1,ispec)) then + if (iMPIcut_xi(1,ispec) .and. iMPIcut_eta(1,ispec)) then ispeccount=ispeccount+1 ! loop on all the points ix = 1 iy = 1 do iz=1,NGLLZ ! select point, if not already selected - if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then + if (.not. mask_ibool(ibool(ix,iy,iz,ispec))) then mask_ibool(ibool(ix,iy,iz,ispec)) = .true. npoin1D = npoin1D + 1 write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), & @@ -116,7 +116,7 @@ subroutine get_MPI_1D_buffers(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool, close(10) ! compare number of edge elements detected to analytical value - if(ispeccount /= NSPEC1D_RADIAL_CORNER(iregion,1) .or. npoin1D /= NGLOB1D_RADIAL_CORNER(iregion,1)) & + if (ispeccount /= NSPEC1D_RADIAL_CORNER(iregion,1) .or. npoin1D /= NGLOB1D_RADIAL_CORNER(iregion,1)) & call exit_MPI(myrank,'error MPI 1D buffer detection in xi=left') ! determine if the element falls on the right MPI cut plane @@ -134,19 +134,19 @@ subroutine get_MPI_1D_buffers(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool, ispeccount=0 do ispec=1,nspec ! remove central cube for chunk buffers - if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. & + if (idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. & idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. & idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. & idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle ! corner detection here - if(iMPIcut_xi(2,ispec) .and. iMPIcut_eta(1,ispec)) then + if (iMPIcut_xi(2,ispec) .and. iMPIcut_eta(1,ispec)) then ispeccount=ispeccount+1 ! loop on all the points ix = NGLLX iy = 1 do iz=1,NGLLZ ! select point, if not already selected - if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then + if (.not. mask_ibool(ibool(ix,iy,iz,ispec))) then mask_ibool(ibool(ix,iy,iz,ispec)) = .true. npoin1D = npoin1D + 1 write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), & @@ -165,7 +165,7 @@ subroutine get_MPI_1D_buffers(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool, close(10) ! compare number of edge elements and points detected to analytical value - if(ispeccount /= NSPEC1D_RADIAL_CORNER(iregion,2) .or. npoin1D /= NGLOB1D_RADIAL_CORNER(iregion,2)) & + if (ispeccount /= NSPEC1D_RADIAL_CORNER(iregion,2) .or. npoin1D /= NGLOB1D_RADIAL_CORNER(iregion,2)) & call exit_MPI(myrank,'error MPI 1D buffer detection in xi=right') ! ***************************************************************** @@ -189,13 +189,13 @@ subroutine get_MPI_1D_buffers(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool, do ispec=1,nspec ! remove central cube for chunk buffers - if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. & + if (idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. & idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. & idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. & idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle ! corner detection here - if(iMPIcut_xi(1,ispec) .and. iMPIcut_eta(2,ispec)) then + if (iMPIcut_xi(1,ispec) .and. iMPIcut_eta(2,ispec)) then ispeccount=ispeccount+1 @@ -205,7 +205,7 @@ subroutine get_MPI_1D_buffers(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool, do iz=1,NGLLZ ! select point, if not already selected - if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then + if (.not. mask_ibool(ibool(ix,iy,iz,ispec))) then mask_ibool(ibool(ix,iy,iz,ispec)) = .true. npoin1D = npoin1D + 1 write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), & @@ -224,7 +224,7 @@ subroutine get_MPI_1D_buffers(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool, close(10) ! compare number of edge elements detected to analytical value - if(ispeccount /= NSPEC1D_RADIAL_CORNER(iregion,4) .or. npoin1D /= NGLOB1D_RADIAL_CORNER(iregion,4)) & + if (ispeccount /= NSPEC1D_RADIAL_CORNER(iregion,4) .or. npoin1D /= NGLOB1D_RADIAL_CORNER(iregion,4)) & call exit_MPI(myrank,'error MPI 1D buffer detection in xi=left') ! determine if the element falls on the right MPI cut plane @@ -244,13 +244,13 @@ subroutine get_MPI_1D_buffers(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool, do ispec=1,nspec ! remove central cube for chunk buffers - if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. & + if (idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. & idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. & idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. & idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle ! corner detection here - if(iMPIcut_xi(2,ispec) .and. iMPIcut_eta(2,ispec)) then + if (iMPIcut_xi(2,ispec) .and. iMPIcut_eta(2,ispec)) then ispeccount=ispeccount+1 @@ -260,7 +260,7 @@ subroutine get_MPI_1D_buffers(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool, do iz=1,NGLLZ ! select point, if not already selected - if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then + if (.not. mask_ibool(ibool(ix,iy,iz,ispec))) then mask_ibool(ibool(ix,iy,iz,ispec)) = .true. npoin1D = npoin1D + 1 write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), & @@ -279,7 +279,7 @@ subroutine get_MPI_1D_buffers(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool, close(10) ! compare number of edge elements and points detected to analytical value - if(ispeccount /= NSPEC1D_RADIAL_CORNER(iregion,3) .or. npoin1D /= NGLOB1D_RADIAL_CORNER(iregion,3)) & + if (ispeccount /= NSPEC1D_RADIAL_CORNER(iregion,3) .or. npoin1D /= NGLOB1D_RADIAL_CORNER(iregion,3)) & call exit_MPI(myrank,'error MPI 1D buffer detection in xi=right') end subroutine get_MPI_1D_buffers diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_MPI_cutplanes_eta.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_MPI_cutplanes_eta.f90 index 1eb8e3c04..31131d202 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_MPI_cutplanes_eta.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_MPI_cutplanes_eta.f90 @@ -110,14 +110,14 @@ subroutine get_MPI_cutplanes_eta(myrank,prname,nspec,iMPIcut_eta,ibool, & ispecc1=0 do ispec=1,nspec - if(iMPIcut_eta(1,ispec)) then + if (iMPIcut_eta(1,ispec)) then ispecc1=ispecc1+1 ! loop on all the points in that 2-D element, including edges iy = 1 do ix=1,NGLLX do iz=1,NGLLZ ! select point, if not already selected - if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then + if (.not. mask_ibool(ibool(ix,iy,iz,ispec))) then mask_ibool(ibool(ix,iy,iz,ispec)) = .true. npoin2D_eta = npoin2D_eta + 1 if (USE_MESH_COLORING_INNER_OUTER) then @@ -153,7 +153,7 @@ subroutine get_MPI_cutplanes_eta(myrank,prname,nspec,iMPIcut_eta,ibool, & close(10) ! compare number of surface elements detected to analytical value - if(ispecc1 /= nspec2Dtheor) call exit_MPI(myrank,'error MPI cut-planes detection in eta=left') + if (ispecc1 /= nspec2Dtheor) call exit_MPI(myrank,'error MPI cut-planes detection in eta=left') ! ! determine if the element falls on the right MPI cut plane @@ -173,14 +173,14 @@ subroutine get_MPI_cutplanes_eta(myrank,prname,nspec,iMPIcut_eta,ibool, & ispecc2=0 do ispec=1,nspec - if(iMPIcut_eta(2,ispec)) then + if (iMPIcut_eta(2,ispec)) then ispecc2=ispecc2+1 ! loop on all the points in that 2-D element, including edges iy = NGLLY do ix=1,NGLLX do iz=1,NGLLZ ! select point, if not already selected - if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then + if (.not. mask_ibool(ibool(ix,iy,iz,ispec))) then mask_ibool(ibool(ix,iy,iz,ispec)) = .true. npoin2D_eta = npoin2D_eta + 1 if (USE_MESH_COLORING_INNER_OUTER) then @@ -216,7 +216,7 @@ subroutine get_MPI_cutplanes_eta(myrank,prname,nspec,iMPIcut_eta,ibool, & close(10) ! compare number of surface elements detected to analytical value - if(ispecc2 /= nspec2Dtheor) call exit_MPI(myrank,'error MPI cut-planes detection in eta=right') + if (ispecc2 /= nspec2Dtheor) call exit_MPI(myrank,'error MPI cut-planes detection in eta=right') if (USE_MESH_COLORING_INNER_OUTER) then deallocate(ibool_selected) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_MPI_cutplanes_xi.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_MPI_cutplanes_xi.f90 index 498996a7d..dc0acf027 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_MPI_cutplanes_xi.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_MPI_cutplanes_xi.f90 @@ -108,14 +108,14 @@ subroutine get_MPI_cutplanes_xi(myrank,prname,nspec,iMPIcut_xi,ibool, & ispecc1=0 do ispec=1,nspec - if(iMPIcut_xi(1,ispec)) then + if (iMPIcut_xi(1,ispec)) then ispecc1=ispecc1+1 ! loop on all the points in that 2-D element, including edges ix = 1 do iy=1,NGLLY do iz=1,NGLLZ ! select point, if not already selected - if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then + if (.not. mask_ibool(ibool(ix,iy,iz,ispec))) then mask_ibool(ibool(ix,iy,iz,ispec)) = .true. npoin2D_xi = npoin2D_xi + 1 if (USE_MESH_COLORING_INNER_OUTER) then @@ -151,7 +151,7 @@ subroutine get_MPI_cutplanes_xi(myrank,prname,nspec,iMPIcut_xi,ibool, & close(10) ! compare number of surface elements detected to analytical value - if(ispecc1 /= nspec2Dtheor) then + if (ispecc1 /= nspec2Dtheor) then write(errmsg,*) 'error MPI cut-planes detection in xi=left T=',nspec2Dtheor,' C=',ispecc1 call exit_MPI(myrank,errmsg) endif @@ -173,14 +173,14 @@ subroutine get_MPI_cutplanes_xi(myrank,prname,nspec,iMPIcut_xi,ibool, & ispecc2=0 do ispec=1,nspec - if(iMPIcut_xi(2,ispec)) then + if (iMPIcut_xi(2,ispec)) then ispecc2=ispecc2+1 ! loop on all the points in that 2-D element, including edges ix = NGLLX do iy=1,NGLLY do iz=1,NGLLZ ! select point, if not already selected - if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then + if (.not. mask_ibool(ibool(ix,iy,iz,ispec))) then mask_ibool(ibool(ix,iy,iz,ispec)) = .true. npoin2D_xi = npoin2D_xi + 1 if (USE_MESH_COLORING_INNER_OUTER) then @@ -217,7 +217,7 @@ subroutine get_MPI_cutplanes_xi(myrank,prname,nspec,iMPIcut_xi,ibool, & close(10) ! compare number of surface elements detected to analytical value - if(ispecc2 /= nspec2Dtheor) then + if (ispecc2 /= nspec2Dtheor) then write(errmsg,*) 'error MPI cut-planes detection in xi=right T=',nspec2Dtheor,' C=',ispecc2 call exit_MPI(myrank,errmsg) endif diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_absorb.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_absorb.f90 index c48fd999d..1b7a01966 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_absorb.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_absorb.f90 @@ -66,7 +66,7 @@ subroutine get_absorb(myrank,iboun,nspec, & ! determine if the element falls on an absorbing boundary - if(iboun(1,ispecg)) then + if (iboun(1,ispecg)) then ! on boundary 1: xmin ispecb1=ispecb1+1 @@ -77,10 +77,10 @@ subroutine get_absorb(myrank,iboun,nspec, & ! check for ovelap with other boundaries nkmin_xi(1,ispecb1)=1 - if(iboun(5,ispecg)) nkmin_xi(1,ispecb1)=2 + if (iboun(5,ispecg)) nkmin_xi(1,ispecb1)=2 endif - if(iboun(2,ispecg)) then + if (iboun(2,ispecg)) then ! on boundary 2: xmax ispecb2=ispecb2+1 @@ -91,44 +91,44 @@ subroutine get_absorb(myrank,iboun,nspec, & ! check for ovelap with other boundaries nkmin_xi(2,ispecb2)=1 - if(iboun(5,ispecg)) nkmin_xi(2,ispecb2)=2 + if (iboun(5,ispecg)) nkmin_xi(2,ispecb2)=2 endif - if(iboun(3,ispecg)) then + if (iboun(3,ispecg)) then ! on boundary 3: ymin ispecb3=ispecb3+1 ! check for ovelap with other boundaries nimin(1,ispecb3)=1 - if(iboun(1,ispecg)) nimin(1,ispecb3)=2 + if (iboun(1,ispecg)) nimin(1,ispecb3)=2 nimax(1,ispecb3)=NGLLX - if(iboun(2,ispecg)) nimax(1,ispecb3)=NGLLX-1 + if (iboun(2,ispecg)) nimax(1,ispecb3)=NGLLX-1 nkmin_eta(1,ispecb3)=1 - if(iboun(5,ispecg)) nkmin_eta(1,ispecb3)=2 + if (iboun(5,ispecg)) nkmin_eta(1,ispecb3)=2 endif - if(iboun(4,ispecg)) then + if (iboun(4,ispecg)) then ! on boundary 4: ymax ispecb4=ispecb4+1 ! check for ovelap with other boundaries nimin(2,ispecb4)=1 - if(iboun(1,ispecg)) nimin(2,ispecb4)=2 + if (iboun(1,ispecg)) nimin(2,ispecb4)=2 nimax(2,ispecb4)=NGLLX - if(iboun(2,ispecg)) nimax(2,ispecb4)=NGLLX-1 + if (iboun(2,ispecg)) nimax(2,ispecb4)=NGLLX-1 nkmin_eta(2,ispecb4)=1 - if(iboun(5,ispecg)) nkmin_eta(2,ispecb4)=2 + if (iboun(5,ispecg)) nkmin_eta(2,ispecb4)=2 endif ! on boundary 5: bottom - if(iboun(5,ispecg)) ispecb5=ispecb5+1 + if (iboun(5,ispecg)) ispecb5=ispecb5+1 enddo ! check theoretical value of elements at the bottom - if(ispecb5 /= NSPEC2D_BOTTOM) & + if (ispecb5 /= NSPEC2D_BOTTOM) & call exit_MPI(myrank,'ispecb5 should equal NSPEC2D_BOTTOM in absorbing boundary detection') ! save these temporary arrays for the solver for Stacey conditions diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_backazimuth.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_backazimuth.f90 index 19b43a838..133600f35 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_backazimuth.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_backazimuth.f90 @@ -82,7 +82,7 @@ subroutine get_backazimuth(the,phe,ths,phs,baz) ! GLOBAL INPUT: ! MACH: !===================================================================== - ! SUBROUTINES CALLED: + ! subroutineS CALLED: ! SACLIB: SETMSG, APCMSG !===================================================================== ! LOCAL VARIABLES: @@ -104,7 +104,7 @@ subroutine get_backazimuth(the,phe,ths,phs,baz) ! (Equations are unstable for latidudes of exactly 0 degrees.) temp = the - if( temp == 0. ) temp = 1.0e-08 + if ( temp == 0. ) temp = 1.0e-08 therad = TORAD*temp pherad = TORAD*phe @@ -130,7 +130,7 @@ subroutine get_backazimuth(the,phe,ths,phs,baz) ! -- Convert to radians. temp = Ths - if( temp == 0. ) temp = 1.0e-08 + if ( temp == 0. ) temp = 1.0e-08 thsrad = TORAD*temp phsrad = TORAD*Phs @@ -156,19 +156,19 @@ subroutine get_backazimuth(the,phe,ths,phs,baz) sd = 0.5*sqrt( ((a - a1)**2 + (b - b1)**2 + (c - & c1)**2)*((a + a1)**2 + (b + b1)**2 + (c + c1)**2) ) Xdeg = atan2( sd, sc )*TODEG - if( Xdeg < 0. ) & + if ( Xdeg < 0. ) & Xdeg = Xdeg + twopideg ss = (a1 - d)**2 + (b1 - e)**2 + (c1)**2 - 2. sc = (a1 - g)**2 + (b1 - h)**2 + (c1 - f)**2 - 2. Az = atan2( ss, sc )*TODEG - if( Az < 0. ) & + if ( Az < 0. ) & Az = Az + twopideg ss = (a - d1)**2 + (b - e1)**2 + (c)**2 - 2. sc = (a - g1)**2 + (b - h1)**2 + (c - f1)**2 - 2. Baz = atan2( ss, sc )*TODEG - if( Baz < 0. ) & + if ( Baz < 0. ) & Baz = Baz + twopideg end subroutine get_backazimuth diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_cmt.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_cmt.f90 index fa81b803d..ece06e5ef 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_cmt.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_cmt.f90 @@ -111,7 +111,7 @@ subroutine get_cmt(yr,jda,ho,mi,sec,t_cmt,hdur,lat,long,depth,moment_tensor,DT,N ! null half-duration indicates a Heaviside ! replace with very short error function - if(hdur(isource) < 5. * DT) hdur(isource) = 5. * DT + if (hdur(isource) < 5. * DT) hdur(isource) = 5. * DT enddo @@ -143,7 +143,7 @@ integer function julian_day(yr,mo,da) data mon /0,31,59,90,120,151,181,212,243,273,304,334/ julian_day = da + mon(mo) - if(mo>2) julian_day = julian_day + lpyr(yr) + if (mo>2) julian_day = julian_day + lpyr(yr) end function julian_day @@ -158,11 +158,11 @@ integer function lpyr(yr) !---- returns 1 if leap year ! lpyr=0 - if(mod(yr,400) == 0) then + if (mod(yr,400) == 0) then lpyr=1 - else if(mod(yr,4) == 0) then + else if (mod(yr,4) == 0) then lpyr=1 - if(mod(yr,100) == 0) lpyr=0 + if (mod(yr,100) == 0) lpyr=0 endif end function lpyr @@ -179,7 +179,7 @@ logical function is_leap_year(yr) integer, external :: lpyr !---- function lpyr above returns 1 if leap year - if(lpyr(yr) == 1) then + if (lpyr(yr) == 1) then is_leap_year = .true. else is_leap_year = .false. diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_jacobian_boundaries.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_jacobian_boundaries.f90 index c0896aa97..bd83e4572 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_jacobian_boundaries.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_jacobian_boundaries.f90 @@ -84,8 +84,8 @@ subroutine get_jacobian_boundaries(myrank,iboun,nspec,xstore,ystore,zstore, & double precision xelm(NGNOD2D),yelm(NGNOD2D),zelm(NGNOD2D) ! check that the parameter file is correct - if(NGNOD /= 27) call exit_MPI(myrank,'elements should have 27 control nodes') - if(NGNOD2D /= 9) call exit_MPI(myrank,'surface elements should have 9 control nodes') + if (NGNOD /= 27) call exit_MPI(myrank,'elements should have 27 control nodes') + if (NGNOD2D /= 9) call exit_MPI(myrank,'surface elements should have 9 control nodes') ispecb1 = 0 ispecb2 = 0 @@ -100,7 +100,7 @@ subroutine get_jacobian_boundaries(myrank,iboun,nspec,xstore,ystore,zstore, & ! on boundary: xmin - if(iboun(1,ispec)) then + if (iboun(1,ispec)) then ispecb1=ispecb1+1 ibelm_xmin(ispecb1)=ispec @@ -141,7 +141,7 @@ subroutine get_jacobian_boundaries(myrank,iboun,nspec,xstore,ystore,zstore, & ! on boundary: xmax - if(iboun(2,ispec)) then + if (iboun(2,ispec)) then ispecb2=ispecb2+1 ibelm_xmax(ispecb2)=ispec @@ -182,7 +182,7 @@ subroutine get_jacobian_boundaries(myrank,iboun,nspec,xstore,ystore,zstore, & ! on boundary: ymin - if(iboun(3,ispec)) then + if (iboun(3,ispec)) then ispecb3=ispecb3+1 ibelm_ymin(ispecb3)=ispec @@ -223,7 +223,7 @@ subroutine get_jacobian_boundaries(myrank,iboun,nspec,xstore,ystore,zstore, & ! on boundary: ymax - if(iboun(4,ispec)) then + if (iboun(4,ispec)) then ispecb4=ispecb4+1 ibelm_ymax(ispecb4)=ispec @@ -264,7 +264,7 @@ subroutine get_jacobian_boundaries(myrank,iboun,nspec,xstore,ystore,zstore, & ! on boundary: bottom - if(iboun(5,ispec)) then + if (iboun(5,ispec)) then ispecb5=ispecb5+1 ibelm_bottom(ispecb5)=ispec @@ -304,7 +304,7 @@ subroutine get_jacobian_boundaries(myrank,iboun,nspec,xstore,ystore,zstore, & ! on boundary: top - if(iboun(6,ispec)) then + if (iboun(6,ispec)) then ispecb6=ispecb6+1 ibelm_top(ispecb6)=ispec @@ -346,12 +346,12 @@ subroutine get_jacobian_boundaries(myrank,iboun,nspec,xstore,ystore,zstore, & ! check theoretical value of elements at the bottom - if(ispecb5 /= NSPEC2D_BOTTOM) then + if (ispecb5 /= NSPEC2D_BOTTOM) then call exit_MPI(myrank,'ispecb5 should equal NSPEC2D_BOTTOM') endif ! check theoretical value of elements at the top - if(ispecb6 /= NSPEC2D_TOP) call exit_MPI(myrank,'ispecb6 should equal NSPEC2D_TOP') + if (ispecb6 /= NSPEC2D_TOP) call exit_MPI(myrank,'ispecb6 should equal NSPEC2D_TOP') nspec2D_xmin = ispecb1 nspec2D_xmax = ispecb2 @@ -405,12 +405,12 @@ subroutine compute_jacobian_2D(myrank,ispecb,xelm,yelm,zelm,dershape2D,jacobian2 uny=zxi*xeta-zeta*xxi unz=xxi*yeta-xeta*yxi jacobian=dsqrt(unx**2+uny**2+unz**2) - if(jacobian == ZERO) call exit_MPI(myrank,'2D Jacobian undefined') + if (jacobian == ZERO) call exit_MPI(myrank,'2D Jacobian undefined') ! normalize normal vector and store surface jacobian ! distinguish between single and double precision for reals - if(CUSTOM_REAL == SIZE_REAL) then + if (CUSTOM_REAL == SIZE_REAL) then jacobian2D(i,j,ispecb)=sngl(jacobian) normal(1,i,j,ispecb)=sngl(unx/jacobian) normal(2,i,j,ispecb)=sngl(uny/jacobian) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_model.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_model.f90 index db8bfd70e..f012eb591 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_model.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_model.f90 @@ -347,17 +347,17 @@ subroutine get_model(myrank,iregion_code,nspec, & ! make sure we are within the right shell in PREM to honor discontinuities ! use small geometrical tolerance r_prem = r - if(r <= rmin*1.000001d0) r_prem = rmin*1.000001d0 - if(r >= rmax*0.999999d0) r_prem = rmax*0.999999d0 + if (r <= rmin*1.000001d0) r_prem = rmin*1.000001d0 + if (r >= rmax*0.999999d0) r_prem = rmax*0.999999d0 ! get the anisotropic PREM parameters - if(TRANSVERSE_ISOTROPY) then - if(REFERENCE_1D_MODEL == REFERENCE_MODEL_PREM) then + if (TRANSVERSE_ISOTROPY) then + if (REFERENCE_1D_MODEL == REFERENCE_MODEL_PREM) then call prem_aniso(myrank,r_prem,rho,vpv,vph,vsv,vsh,eta_aniso, & Qkappa,Qmu,idoubling,CRUSTAL,ONE_CRUST,RICB,RCMB,RTOPDDOUBLEPRIME, & R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN) - else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then + else if (REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then call model_ref(r_prem,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu,iregion_code,CRUSTAL,Mref_V) else @@ -366,28 +366,28 @@ subroutine get_model(myrank,iregion_code,nspec, & else - if(REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) then + if (REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) then call model_iasp91(myrank,r_prem,rho,vp,vs,Qkappa,Qmu,idoubling, & ONE_CRUST,.true.,RICB,RCMB,RTOPDDOUBLEPRIME,R771,R670,R400,R220,R120,RMOHO,RMIDDLE_CRUST) - else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_PREM) then + else if (REFERENCE_1D_MODEL == REFERENCE_MODEL_PREM) then call prem_iso(myrank,r_prem,rho,drhodr,vp,vs,Qkappa,Qmu,idoubling,CRUSTAL, & ONE_CRUST,.true.,RICB,RCMB,RTOPDDOUBLEPRIME, & R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN) - else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then + else if (REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then call model_1066a(r_prem,rho,vp,vs,Qkappa,Qmu,iregion_code,M1066a_V) - else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135) then + else if (REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135) then call model_ak135(r_prem,rho,vp,vs,Qkappa,Qmu,iregion_code,Mak135_V) - else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then + else if (REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then call model_ref(r_prem,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu,iregion_code,CRUSTAL,Mref_V) - if(.not. ISOTROPIC_3D_MANTLE) then + if (.not. ISOTROPIC_3D_MANTLE) then vp = sqrt(((8.d0+4.d0*eta_aniso)*vph*vph + 3.d0*vpv*vpv + (8.d0 - 8.d0*eta_aniso)*vsv*vsv)/15.d0) vs = sqrt(((1.d0-2.d0*eta_aniso)*vph*vph + vpv*vpv + 5.d0*vsh*vsh + (6.d0+4.d0*eta_aniso)*vsv*vsv)/15.d0) endif - else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_JP1D) then + else if (REFERENCE_1D_MODEL == REFERENCE_MODEL_JP1D) then call model_jp1d(myrank,r_prem,rho,vp,vs,Qkappa,Qmu,idoubling, & .true.,RICB,RCMB,RTOPDDOUBLEPRIME, & R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST) @@ -396,7 +396,7 @@ subroutine get_model(myrank,iregion_code,nspec, & vsv = vs vsh = vs eta_aniso = 1.d0 - else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) then + else if (REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) then call model_sea1d(r_prem,rho,vp,vs,Qkappa,Qmu,iregion_code,SEA1DM_V) vpv = vp vph = vp @@ -408,7 +408,7 @@ subroutine get_model(myrank,iregion_code,nspec, & endif ! in the case of s362iso we want to save the anisotropic constants for the Voight average - if(.not. (REFERENCE_1D_MODEL == REFERENCE_MODEL_REF .and. ISOTROPIC_3D_MANTLE)) then + if (.not. (REFERENCE_1D_MODEL == REFERENCE_MODEL_REF .and. ISOTROPIC_3D_MANTLE)) then vpv = vp vph = vp vsv = vs @@ -418,11 +418,11 @@ subroutine get_model(myrank,iregion_code,nspec, & endif ! get the 3-D model parameters - if(ISOTROPIC_3D_MANTLE) then - if(r_prem > RCMB/R_EARTH .and. r_prem < RMOHO/R_EARTH) then + if (ISOTROPIC_3D_MANTLE) then + if (r_prem > RCMB/R_EARTH .and. r_prem < RMOHO/R_EARTH) then call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi) call reduce(theta,phi) - if(THREE_D_MODEL == THREE_D_MODEL_S20RTS) then + if (THREE_D_MODEL == THREE_D_MODEL_S20RTS) then ! s20rts dvs = ZERO dvp = ZERO @@ -433,7 +433,7 @@ subroutine get_model(myrank,iregion_code,nspec, & vsv=vsv*(1.0d0+dvs) vsh=vsh*(1.0d0+dvs) rho=rho*(1.0d0+drho) - else if(THREE_D_MODEL == THREE_D_MODEL_SEA99_JP3D) then + else if (THREE_D_MODEL == THREE_D_MODEL_SEA99_JP3D) then ! sea99 + jp3d1994 dvs = ZERO dvp = ZERO @@ -445,9 +445,9 @@ subroutine get_model(myrank,iregion_code,nspec, & vsh=vsh*(1.0d0+dvs) rho=rho*(1.0d0+drho) ! use Lebedev model as background and add vp & vs perturbation from Zhao 1994 model - if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) & + if (theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) & .and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then - if(r_prem > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then + if (r_prem > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then call iso3d_dpzhao_model(r,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V) vpv=vpv*(1.0d0+dvp) vph=vph*(1.0d0+dvp) @@ -455,7 +455,7 @@ subroutine get_model(myrank,iregion_code,nspec, & vsh=vsh*(1.0d0+dvs) endif endif - else if(THREE_D_MODEL == THREE_D_MODEL_SEA99) then + else if (THREE_D_MODEL == THREE_D_MODEL_SEA99) then ! sea99 dvs = ZERO dvp = ZERO @@ -466,14 +466,14 @@ subroutine get_model(myrank,iregion_code,nspec, & vsv=vsv*(1.0d0+dvs) vsh=vsh*(1.0d0+dvs) rho=rho*(1.0d0+drho) - else if(THREE_D_MODEL == THREE_D_MODEL_JP3D) then + else if (THREE_D_MODEL == THREE_D_MODEL_JP3D) then ! jp3d1994 dvs = ZERO dvp = ZERO drho = ZERO - if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) & + if (theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) & .and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then - if(r_prem > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then + if (r_prem > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then call iso3d_dpzhao_model(r,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V) vpv=vpv*(1.0d0+dvp) vph=vph*(1.0d0+dvp) @@ -481,7 +481,7 @@ subroutine get_model(myrank,iregion_code,nspec, & vsh=vsh*(1.0d0+dvs) endif endif - else if(THREE_D_MODEL == THREE_D_MODEL_S362ANI .or. THREE_D_MODEL == THREE_D_MODEL_S362WMANI & + else if (THREE_D_MODEL == THREE_D_MODEL_S362ANI .or. THREE_D_MODEL == THREE_D_MODEL_S362WMANI & .or. THREE_D_MODEL == THREE_D_MODEL_S362ANI_PREM .or. THREE_D_MODEL == THREE_D_MODEL_S29EA) then ! 3D Harvard models s362ani, s362wmani, s362ani_prem and s2.9ea dvpv = 0. @@ -496,7 +496,7 @@ subroutine get_model(myrank,iregion_code,nspec, & lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, & nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, & coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr) - if(TRANSVERSE_ISOTROPY) then + if (TRANSVERSE_ISOTROPY) then vpv=vpv*(1.0d0+dble(dvpv)) vph=vph*(1.0d0+dble(dvph)) vsv=vsv*(1.0d0+dble(dvsv)) @@ -519,11 +519,11 @@ subroutine get_model(myrank,iregion_code,nspec, & endif ! extend 3-D mantle model above the Moho to the surface before adding the crust - else if(r_prem >= RMOHO/R_EARTH) then + else if (r_prem >= RMOHO/R_EARTH) then call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi) call reduce(theta,phi) r_moho = 0.999999d0*RMOHO/R_EARTH - if(THREE_D_MODEL == THREE_D_MODEL_S20RTS) then + if (THREE_D_MODEL == THREE_D_MODEL_S20RTS) then ! s20rts dvs = ZERO dvp = ZERO @@ -534,7 +534,7 @@ subroutine get_model(myrank,iregion_code,nspec, & vsv=vsv*(1.0d0+dvs) vsh=vsh*(1.0d0+dvs) rho=rho*(1.0d0+drho) - else if(THREE_D_MODEL == THREE_D_MODEL_SEA99_JP3D) then + else if (THREE_D_MODEL == THREE_D_MODEL_SEA99_JP3D) then ! sea99 + jp3d1994 dvs = ZERO dvp = ZERO @@ -546,7 +546,7 @@ subroutine get_model(myrank,iregion_code,nspec, & vsh=vsh*(1.0d0+dvs) rho=rho*(1.0d0+drho) ! use Lebedev's model as background and add vp & vs perturbation from Zhao's 1994 model - if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) & + if (theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) & .and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then call iso3d_dpzhao_model(r_moho,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V) vpv=vpv*(1.0d0+dvp) @@ -554,7 +554,7 @@ subroutine get_model(myrank,iregion_code,nspec, & vsv=vsv*(1.0d0+dvs) vsh=vsh*(1.0d0+dvs) endif - else if(THREE_D_MODEL == THREE_D_MODEL_SEA99) then + else if (THREE_D_MODEL == THREE_D_MODEL_SEA99) then ! sea99 dvs = ZERO dvp = ZERO @@ -565,12 +565,12 @@ subroutine get_model(myrank,iregion_code,nspec, & vsv=vsv*(1.0d0+dvs) vsh=vsh*(1.0d0+dvs) rho=rho*(1.0d0+drho) - else if(THREE_D_MODEL == THREE_D_MODEL_JP3D) then + else if (THREE_D_MODEL == THREE_D_MODEL_JP3D) then ! jp3d1994 dvs = ZERO dvp = ZERO drho = ZERO - if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) & + if (theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) & .and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then call iso3d_dpzhao_model(r_moho,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V) vpv=vpv*(1.0d0+dvp) @@ -578,7 +578,7 @@ subroutine get_model(myrank,iregion_code,nspec, & vsv=vsv*(1.0d0+dvs) vsh=vsh*(1.0d0+dvs) endif - else if(THREE_D_MODEL == THREE_D_MODEL_S362ANI .or. THREE_D_MODEL == THREE_D_MODEL_S362WMANI & + else if (THREE_D_MODEL == THREE_D_MODEL_S362ANI .or. THREE_D_MODEL == THREE_D_MODEL_S362WMANI & .or. THREE_D_MODEL == THREE_D_MODEL_S362ANI_PREM .or. THREE_D_MODEL == THREE_D_MODEL_S29EA) then ! 3D Harvard models s362ani, s362wmani, s362ani_prem and s2.9ea dvpv = 0. @@ -593,7 +593,7 @@ subroutine get_model(myrank,iregion_code,nspec, & lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, & nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, & coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr) - if(TRANSVERSE_ISOTROPY) then + if (TRANSVERSE_ISOTROPY) then vpv=vpv*(1.0d0+dble(dvpv)) vph=vph*(1.0d0+dble(dvph)) vsv=vsv*(1.0d0+dble(dvsv)) @@ -618,19 +618,19 @@ subroutine get_model(myrank,iregion_code,nspec, & endif endif - if(ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) & + if (ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) & call aniso_inner_core_model(r_prem,c11,c33,c12,c13,c44,REFERENCE_1D_MODEL) - if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then + if (ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then ! anisotropic model between the Moho and 670 km (change to CMB if desired) - if(r_prem < RMOHO/R_EARTH .and. r_prem > R670/R_EARTH) then + if (r_prem < RMOHO/R_EARTH .and. r_prem > R670/R_EARTH) then call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi) call reduce(theta,phi) call aniso_mantle_model(r_prem,theta,phi,rho,c11,c12,c13,c14,c15,c16, & c22,c23,c24,c25,c26,c33,c34,c35,c36,c44,c45,c46,c55,c56,c66,AMM_V) ! extend 3-D mantle model above the Moho to the surface before adding the crust - else if(r_prem >= RMOHO/R_EARTH) then + else if (r_prem >= RMOHO/R_EARTH) then call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi) call reduce(theta,phi) r_moho = RMOHO/R_EARTH @@ -663,7 +663,7 @@ subroutine get_model(myrank,iregion_code,nspec, & endif ! This is here to identify how and where to include 3D attenuation - if(ATTENUATION .and. ATTENUATION_3D) then + if (ATTENUATION .and. ATTENUATION_3D) then tau_e(:) = 0.0d0 ! Get the value of Qmu (Attenuation) dependedent on ! the radius (r_prem) and idoubling flag @@ -674,23 +674,23 @@ subroutine get_model(myrank,iregion_code,nspec, & endif ! get the 3-D crustal model - if(CRUSTAL) then - if(r > R_DEEPEST_CRUST) then + if (CRUSTAL) then + if (r > R_DEEPEST_CRUST) then call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi) call reduce(theta,phi) - if(THREE_D_MODEL == THREE_D_MODEL_SEA99_JP3D .or. THREE_D_MODEL == THREE_D_MODEL_JP3D) then - if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) & + if (THREE_D_MODEL == THREE_D_MODEL_SEA99_JP3D .or. THREE_D_MODEL == THREE_D_MODEL_JP3D) then + if (theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) & .and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then - if(r > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then + if (r > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then call iso3d_dpzhao_model(r,theta,phi,vpc,vsc,dvp,dvs,rhoc,found_crust,JP3DM_V) - if(found_crust) then + if (found_crust) then vpv=vpc vph=vpc vsv=vsc vsh=vsc ! rho=rhoc - if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then + if (ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then c11 = rho*vpv*vpv c12 = rho*(vpv*vpv-2.*vsv*vsv) c13 = c12 @@ -718,7 +718,7 @@ subroutine get_model(myrank,iregion_code,nspec, & else lat=(PI/2.0d0-theta)*180.0d0/PI lon=phi*180.0d0/PI - if(lon>180.0d0) lon=lon-360.0d0 + if (lon>180.0d0) lon=lon-360.0d0 call crustal_model(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,CM_V) if (found_crust) then vpv=vpc @@ -727,7 +727,7 @@ subroutine get_model(myrank,iregion_code,nspec, & vsh=vsc rho=rhoc eta_aniso=1.0d0 - if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then + if (ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then c11 = rho*vpv*vpv c12 = rho*(vpv*vpv-2.*vsv*vsv) c13 = c12 @@ -755,7 +755,7 @@ subroutine get_model(myrank,iregion_code,nspec, & else lat=(PI/2.0d0-theta)*180.0d0/PI lon=phi*180.0d0/PI - if(lon>180.0d0) lon=lon-360.0d0 + if (lon>180.0d0) lon=lon-360.0d0 call crustal_model(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,CM_V) if (found_crust) then vpv=vpc @@ -763,7 +763,7 @@ subroutine get_model(myrank,iregion_code,nspec, & vsv=vsc vsh=vsc rho=rhoc - if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then + if (ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then c11 = rho*vpv*vpv c12 = rho*(vpv*vpv-2.*vsv*vsv) c13 = c12 @@ -794,7 +794,7 @@ subroutine get_model(myrank,iregion_code,nspec, & ! define elastic parameters in the model ! distinguish between single and double precision for reals - if(CUSTOM_REAL == SIZE_REAL) then + if (CUSTOM_REAL == SIZE_REAL) then rhostore(i,j,k,ispec) = sngl(rho) kappavstore(i,j,k,ispec) = sngl(rho*(vpv*vpv - 4.d0*vsv*vsv/3.d0)) @@ -803,9 +803,9 @@ subroutine get_model(myrank,iregion_code,nspec, & muhstore(i,j,k,ispec) = sngl(rho*vsh*vsh) eta_anisostore(i,j,k,ispec) = sngl(eta_aniso) - if(ABSORBING_CONDITIONS) then + if (ABSORBING_CONDITIONS) then - if(iregion_code == IREGION_OUTER_CORE) then + if (iregion_code == IREGION_OUTER_CORE) then ! we need just vp in the outer core for Stacey conditions rho_vp(i,j,k,ispec) = sngl(vph) @@ -817,7 +817,7 @@ subroutine get_model(myrank,iregion_code,nspec, & endif endif - if(ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) then + if (ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) then c11store(i,j,k,ispec) = sngl(c11) c33store(i,j,k,ispec) = sngl(c33) @@ -826,7 +826,7 @@ subroutine get_model(myrank,iregion_code,nspec, & c44store(i,j,k,ispec) = sngl(c44) endif - if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then + if (ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then c11store(i,j,k,ispec) = sngl(c11) c12store(i,j,k,ispec) = sngl(c12) @@ -861,8 +861,8 @@ subroutine get_model(myrank,iregion_code,nspec, & muhstore(i,j,k,ispec) = rho*vsh*vsh eta_anisostore(i,j,k,ispec) = eta_aniso - if(ABSORBING_CONDITIONS) then - if(iregion_code == IREGION_OUTER_CORE) then + if (ABSORBING_CONDITIONS) then + if (iregion_code == IREGION_OUTER_CORE) then ! we need just vp in the outer core for Stacey conditions rho_vp(i,j,k,ispec) = vph rho_vs(i,j,k,ispec) = 0.d0 @@ -872,7 +872,7 @@ subroutine get_model(myrank,iregion_code,nspec, & endif endif - if(ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) then + if (ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) then c11store(i,j,k,ispec) = c11 c33store(i,j,k,ispec) = c33 c12store(i,j,k,ispec) = c12 @@ -880,7 +880,7 @@ subroutine get_model(myrank,iregion_code,nspec, & c44store(i,j,k,ispec) = c44 endif - if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then + if (ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then c11store(i,j,k,ispec) = c11 c12store(i,j,k,ispec) = c12 c13store(i,j,k,ispec) = c13 @@ -906,7 +906,7 @@ subroutine get_model(myrank,iregion_code,nspec, & endif - if(ATTENUATION .and. ATTENUATION_3D) then + if (ATTENUATION .and. ATTENUATION_3D) then tau_e_store(:,i,j,k,ispec) = tau_e(:) Qmu_store(i,j,k,ispec) = Qmu endif diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_perm_color.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_perm_color.f90 index 611fe16ca..1ea8dad8b 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_perm_color.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_perm_color.f90 @@ -51,7 +51,7 @@ subroutine get_perm_color(is_on_a_slice_edge,ibool,perm,nspec,nglob, & nglob_GLL_full = nglob !---- call Charbel Farhat's routines - if(myrank == 0) & + if (myrank == 0) & write(IMAIN,*) 'calling form_elt_connectivity_foelco to perform mesh coloring and inner/outer element splitting' call form_elt_connectivity_foelco(mn,mp,nspec,global_corner_number,nglob_GLL_full,ibool,nglob_eight_corners_only) do i=1,nspec @@ -63,7 +63,7 @@ subroutine get_perm_color(is_on_a_slice_edge,ibool,perm,nspec,nglob, & allocate(np(nglob_eight_corners_only+1)) count_only = .true. total_size_ne = 1 - if(myrank == 0) write(IMAIN,*) 'calling form_node_connectivity_fonoco to determine the size of the table' + if (myrank == 0) write(IMAIN,*) 'calling form_node_connectivity_fonoco to determine the size of the table' allocate(ne(total_size_ne)) call form_node_connectivity_fonoco(mn,mp,ne,np,nglob_eight_corners_only,nspec,count_only,total_size_ne) deallocate(ne) @@ -73,7 +73,7 @@ subroutine get_perm_color(is_on_a_slice_edge,ibool,perm,nspec,nglob, & ! now actually generate the array count_only = .false. - if(myrank == 0) write(IMAIN,*) 'calling form_node_connectivity_fonoco to actually create the table' + if (myrank == 0) write(IMAIN,*) 'calling form_node_connectivity_fonoco to actually create the table' call form_node_connectivity_fonoco(mn,mp,ne,np,nglob_eight_corners_only,nspec,count_only,total_size_ne) do i=1,nglob_eight_corners_only istart = np(i) @@ -83,7 +83,7 @@ subroutine get_perm_color(is_on_a_slice_edge,ibool,perm,nspec,nglob, & ! count only, to determine the size needed for the array count_only = .true. total_size_adj = 1 - if(myrank == 0) write(IMAIN,*) 'calling create_adjacency_table_adjncy to determine the size of the table' + if (myrank == 0) write(IMAIN,*) 'calling create_adjacency_table_adjncy to determine the size of the table' allocate(adj(total_size_adj)) call create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec,nglob_eight_corners_only,& count_only,total_size_ne,total_size_adj,.false.) @@ -94,7 +94,7 @@ subroutine get_perm_color(is_on_a_slice_edge,ibool,perm,nspec,nglob, & ! now actually generate the array count_only = .false. - if(myrank == 0) write(IMAIN,*) 'calling create_adjacency_table_adjncy again to actually create the table' + if (myrank == 0) write(IMAIN,*) 'calling create_adjacency_table_adjncy again to actually create the table' call create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec,nglob_eight_corners_only,& count_only,total_size_ne,total_size_adj,.false.) @@ -102,7 +102,7 @@ subroutine get_perm_color(is_on_a_slice_edge,ibool,perm,nspec,nglob, & istart = xadj(i) istop = xadj(i+1) - 1 number_of_neighbors = istop-istart+1 - if(number_of_neighbors < 1 .or. number_of_neighbors > MAX_NUMBER_OF_NEIGHBORS) stop 'incorrect number of neighbors' + if (number_of_neighbors < 1 .or. number_of_neighbors > MAX_NUMBER_OF_NEIGHBORS) stop 'incorrect number of neighbors' enddo deallocate(ne,np) @@ -110,7 +110,7 @@ subroutine get_perm_color(is_on_a_slice_edge,ibool,perm,nspec,nglob, & call get_color(adj,xadj,color,nspec,total_size_adj,is_on_a_slice_edge, & nb_colors_outer_elements,nb_colors_inner_elements,nspec_outer) - if(myrank == 0) then + if (myrank == 0) then write(IMAIN,*) 'number of colors of the graph for inner elements = ',nb_colors_inner_elements write(IMAIN,*) 'number of colors of the graph for outer elements = ',nb_colors_outer_elements write(IMAIN,*) 'total number of colors of the graph (sum of both) = ', & @@ -120,11 +120,11 @@ subroutine get_perm_color(is_on_a_slice_edge,ibool,perm,nspec,nglob, & deallocate(adj) - if(myrank == 0) write(IMAIN,*) 'generating the final colors' + if (myrank == 0) write(IMAIN,*) 'generating the final colors' first_elem_number_in_this_color(:) = -1 call get_final_perm(color,perm,first_elem_number_in_this_color,nspec,nb_colors_inner_elements+nb_colors_outer_elements) - if(myrank == 0) write(IMAIN,*) 'done with mesh coloring and inner/outer element splitting' + if (myrank == 0) write(IMAIN,*) 'done with mesh coloring and inner/outer element splitting' end subroutine get_perm_color @@ -142,7 +142,7 @@ subroutine get_final_perm(color,perm,first_elem_number_in_this_color,nspec,nb_co do icolor = 1, nb_color first_elem_number_in_this_color(icolor) = counter do ielem = 1, nspec - if(color(ielem) == icolor) then + if (color(ielem) == icolor) then perm(ielem) = counter counter = counter + 1 endif @@ -292,17 +292,17 @@ subroutine form_elt_connectivity_foelco(mn,mp,nspec,global_corner_number,& do ix = 1,NGLLX,NGLLX-1 inumcorner = inumcorner + 1 - if(inumcorner > NGNOD_HEXAHEDRA) stop 'corner number too large' + if (inumcorner > NGNOD_HEXAHEDRA) stop 'corner number too large' ! check if this point was already assigned a number previously, otherwise create one and store it - if(global_corner_number(ibool(ix,iy,iz,ispec)) == -1) then + if (global_corner_number(ibool(ix,iy,iz,ispec)) == -1) then nglob_eight_corners_only = nglob_eight_corners_only + 1 global_corner_number(ibool(ix,iy,iz,ispec)) = nglob_eight_corners_only endif node = global_corner_number(ibool(ix,iy,iz,ispec)) do k=nsum,ninter-1 - if(node == mn(k)) goto 200 + if (node == mn(k)) goto 200 enddo mn(ninter) = node @@ -372,7 +372,7 @@ subroutine form_node_connectivity_fonoco(mn,mp,ne,np,nglob_eight_corners_only,& do j=mp(ispec),mp(ispec + 1) - 1 if (mn(j) == inode) then - if(count_only) then + if (count_only) then total_size_ne = nsum else ne(nsum) = ispec @@ -454,12 +454,12 @@ subroutine create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec,nglob jstop = np(node + 1) - 1 do 120 jel=jstart,jstop nelem = ne(jel) - if(maskel(nelem)) goto 120 + if (maskel(nelem)) goto 120 if (face) then ! if 2 elements share at least 3 corners, therefore they share a face countel(nelem) = countel(nelem) + 1 if (countel(nelem)>=3) then - if(count_only) then + if (count_only) then total_size_adj = iad else adj(iad) = nelem @@ -468,7 +468,7 @@ subroutine create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec,nglob iad = iad + 1 endif else - if(count_only) then + if (count_only) then total_size_adj = iad else adj(iad) = nelem diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_shape2D.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_shape2D.f90 index e30758040..c230e1dc7 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_shape2D.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_shape2D.f90 @@ -53,8 +53,8 @@ subroutine get_shape2D(myrank,shape2D,dershape2D,xigll,yigll,NGLLA,NGLLB) double precision sumshape,sumdershapexi,sumdershapeeta ! check that the parameter file is correct - if(NGNOD /= 27) call exit_MPI(myrank,'elements should have 27 control nodes') - if(NGNOD2D /= 9) call exit_MPI(myrank,'surface elements should have 9 control nodes') + if (NGNOD /= 27) call exit_MPI(myrank,'elements should have 27 control nodes') + if (NGNOD2D /= 9) call exit_MPI(myrank,'surface elements should have 9 control nodes') ! generate the 2D shape functions and their derivatives (9 nodes) do i=1,NGLLA @@ -144,13 +144,13 @@ subroutine get_shape2D(myrank,shape2D,dershape2D,xigll,yigll,NGLLA,NGLLB) enddo ! the sum of the shape functions should be 1 - if(abs(sumshape-ONE)>TINYVAL) call exit_MPI(myrank,'error in 2D shape functions') + if (abs(sumshape-ONE)>TINYVAL) call exit_MPI(myrank,'error in 2D shape functions') ! the sum of the derivatives of the shape functions should be 0 - if(abs(sumdershapexi)>TINYVAL) & + if (abs(sumdershapexi)>TINYVAL) & call exit_MPI(myrank,'error in xi derivatives of 2D shape function') - if(abs(sumdershapeeta)>TINYVAL) & + if (abs(sumdershapeeta)>TINYVAL) & call exit_MPI(myrank,'error in eta derivatives of 2D shape function') enddo diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_shape3D.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_shape3D.f90 index 4d39ec9e6..32a93c33b 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_shape3D.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/get_shape3D.f90 @@ -53,7 +53,7 @@ subroutine get_shape3D(myrank,shape3D,dershape3D,xigll,yigll,zigll) double precision sumshape,sumdershapexi,sumdershapeeta,sumdershapegamma ! check that the parameter file is correct - if(NGNOD /= 27) call exit_MPI(myrank,'elements should have 27 control nodes') + if (NGNOD /= 27) call exit_MPI(myrank,'elements should have 27 control nodes') ! generate the 3D shape functions and their derivatives (27 nodes) do i=1,NGLLX @@ -248,16 +248,16 @@ subroutine get_shape3D(myrank,shape3D,dershape3D,xigll,yigll,zigll) enddo ! the sum of the shape functions should be 1 - if(abs(sumshape-ONE) > TINYVAL) call exit_MPI(myrank,'error in 3D shape functions') + if (abs(sumshape-ONE) > TINYVAL) call exit_MPI(myrank,'error in 3D shape functions') ! the sum of the derivatives of the shape functions should be 0 - if(abs(sumdershapexi) > TINYVAL) & + if (abs(sumdershapexi) > TINYVAL) & call exit_MPI(myrank,'error in xi derivatives of 3D shape function') - if(abs(sumdershapeeta) > TINYVAL) & + if (abs(sumdershapeeta) > TINYVAL) & call exit_MPI(myrank,'error in eta derivatives of 3D shape function') - if(abs(sumdershapegamma) > TINYVAL) & + if (abs(sumdershapegamma) > TINYVAL) & call exit_MPI(myrank,'error in gamma derivatives of 3D shape function') enddo diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/gll_library.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/gll_library.f90 index 36986d6f7..d7580022f 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/gll_library.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/gll_library.f90 @@ -178,7 +178,7 @@ subroutine jacg (xjac,np,alpha,beta) pd = 0.d0 jmin = 0 do j=1,np - if(j == 1) then + if (j == 1) then x = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth) else x1 = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth) @@ -194,7 +194,7 @@ subroutine jacg (xjac,np,alpha,beta) enddo delx = -p/(pd-recsum*p) x = x+delx - if(abs(delx) < eps) goto 31 + if (abs(delx) < eps) goto 31 enddo 31 continue xjac(np-j+1) = x @@ -203,12 +203,12 @@ subroutine jacg (xjac,np,alpha,beta) do i=1,np xmin = 2.d0 do j=i,np - if(xjac(j) < xmin) then + if (xjac(j) < xmin) then xmin = xjac(j) jmin = j endif enddo - if(jmin /= i) then + if (jmin /= i) then swap = xjac(i) xjac(i) = xjac(jmin) xjac(jmin) = swap @@ -279,7 +279,7 @@ end subroutine jacobf !------------------------------------------------------------------------ ! - double precision FUNCTION PNDLEG (Z,N) + double precision function PNDLEG (Z,N) !------------------------------------------------------------------------ ! @@ -319,7 +319,7 @@ end function pndleg !------------------------------------------------------------------------ ! - double precision FUNCTION PNLEG (Z,N) + double precision function PNLEG (Z,N) !------------------------------------------------------------------------ ! diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/hex_nodes.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/hex_nodes.f90 index ed2e2e3e6..69f4d9ba8 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/hex_nodes.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/hex_nodes.f90 @@ -38,7 +38,7 @@ subroutine hex_nodes(iaddx,iaddy,iaddz) ! the topology of the nodes is described in UTILS/chunk_notes_scanned/numbering_convention_27_nodes.tif - if(NGNOD /= 27) stop 'elements should have 27 control nodes' + if (NGNOD /= 27) stop 'elements should have 27 control nodes' ! corner nodes diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/intgrl.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/intgrl.f90 index 586c767d6..d95cda5ef 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/intgrl.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/intgrl.f90 @@ -90,8 +90,8 @@ subroutine deriv(y,yprime,n,r,ndis,kdis,s1,s2,s3) ndp=ndis+1 do 3 nd=1,ndp - if(nd == 1) goto 4 - if(nd == ndp) goto 5 + if (nd == 1) goto 4 + if (nd == ndp) goto 5 j1=kdis(nd-1)+1 j2=kdis(nd)-2 goto 6 @@ -100,7 +100,7 @@ subroutine deriv(y,yprime,n,r,ndis,kdis,s1,s2,s3) goto 6 5 j1=kdis(ndis)+1 j2=n-2 - 6 if((j2+1-j1)>0) goto 11 + 6 if ((j2+1-j1)>0) goto 11 j2=j2+2 yy(1)=(y(j2)-y(j1))/(r(j2)-r(j1)) s1(j1)=yy(1) @@ -111,7 +111,7 @@ subroutine deriv(y,yprime,n,r,ndis,kdis,s1,s2,s3) s3(j2)=yy(3) goto 3 11 a0=0.0d0 - if(j1 == 1) goto 7 + if (j1 == 1) goto 7 h=r(j1+1)-r(j1) h2=r(j1+2)-r(j1) yy(1)=h*h2*(h2-h) @@ -122,7 +122,7 @@ subroutine deriv(y,yprime,n,r,ndis,kdis,s1,s2,s3) 7 b0=0.0d0 8 b1=b0 - if(j2 > 1000) stop 'error in subroutine deriv for j2' + if (j2 > 1000) stop 'error in subroutine deriv for j2' do i=j1,j2 h=r(i+1)-r(i) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/jp3d1994_model.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/jp3d1994_model.f90 index 20ea4c6ce..421555966 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/jp3d1994_model.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/jp3d1994_model.f90 @@ -227,13 +227,13 @@ subroutine iso3d_dpzhao_model(radius,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3 ! when LAY = 2, the focus is in the lower crust; ! when LAY = 3, the focus is in the mantle wedge; ! when LAY = 4, the focus is beneath the plate boundary. - IF(HE<=H1) THEN + if (HE<=H1) then LAY = 1 found_crust = .true. - ELSE IF(HE>H1.and.HE<=H2) THEN + ELSE if (HE>H1.and.HE<=H2) then LAY = 2 found_crust = .true. - ELSE IF(HE>H2.and.HE<=H3) THEN + ELSE if (HE>H2.and.HE<=H3) then LAY = 3 ELSE LAY = 4 @@ -248,13 +248,13 @@ subroutine iso3d_dpzhao_model(radius,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3 vs = vs*(1.0d0+dvs) ! determine rho - if(LAY == 1) then + if (LAY == 1) then rho=2.6 endif - if(LAY == 2) then + if (LAY == 2) then rho=2.9 endif - if(LAY > 2) then + if (LAY > 2) then rho=3.3+(vs-4.4)*0.66667 endif ! non-dimensionalize @@ -263,11 +263,11 @@ subroutine iso3d_dpzhao_model(radius,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3 rho=rho*1000.0d0/RHOAV vp=vp*1000.0d0/(R_EARTH*scaleval) vs=vs*1000.0d0/(R_EARTH*scaleval) -END subroutine iso3d_dpzhao_model +end subroutine iso3d_dpzhao_model !--------------------------------------------------------------- - SUBROUTINE INPUT1(JP3DM_V) + subroutine INPUT1(JP3DM_V) implicit none include "constants.h" @@ -346,9 +346,9 @@ SUBROUTINE INPUT1(JP3DM_V) CALL PUT1(JP3DM_V%NPB,JP3DM_V%NRB,JP3DM_V%NHB,JP3DM_V%PNB,JP3DM_V%RNB,JP3DM_V%HNB,JP3DM_V%VELBP) CALL BLDMAP(JP3DM_V) RETURN - END SUBROUTINE INPUT1 + end subroutine INPUT1 - SUBROUTINE PUT1(NPX,NRX,NHX,PNX,RNX,HNX,VELXP) + subroutine PUT1(NPX,NRX,NHX,PNX,RNX,HNX,VELXP) integer :: NPX,NRX,NHX,K,I,J double precision :: VELXP(NPX,NRX,NHX), & PNX(NPX),RNX(NRX),HNX(NHX) @@ -363,9 +363,9 @@ SUBROUTINE PUT1(NPX,NRX,NHX,PNX,RNX,HNX,VELXP) 140 FORMAT(4(14F5.2/)) enddo enddo - END SUBROUTINE PUT1 + end subroutine PUT1 - SUBROUTINE INPUT2(JP3DM_V) + subroutine INPUT2(JP3DM_V) implicit none include "constants.h" @@ -444,13 +444,13 @@ SUBROUTINE INPUT2(JP3DM_V) READ(3,120) (JP3DM_V%RRN(I),I=1,NNR) DO 1 I = NP,1,-1 READ(3,130) (JP3DM_V%DEPA(I,J),J=1,NNR) -1 CONTINUE +1 continue DO 2 I = NP,1,-1 READ(3,130) (JP3DM_V%DEPB(I,J),J=1,NNR) -2 CONTINUE +2 continue DO 3 I = NP,1,-1 READ(3,130) (JP3DM_V%DEPC(I,J),J=1,NNR) -3 CONTINUE +3 continue 100 FORMAT(2I6) 110 FORMAT(5(10F7.2/),F7.2) 120 FORMAT(6(10F7.2/),3F7.2) @@ -458,7 +458,7 @@ SUBROUTINE INPUT2(JP3DM_V) RETURN END - SUBROUTINE BLDMAP(JP3DM_V) + subroutine BLDMAP(JP3DM_V) implicit none include "constants.h" @@ -537,7 +537,7 @@ SUBROUTINE BLDMAP(JP3DM_V) RETURN END - SUBROUTINE LOCX(PNX,RNX,HNX,NPX,NRX,NHX,MKX, & + subroutine LOCX(PNX,RNX,HNX,NPX,NRX,NHX,MKX, & PLX,RLX,HLX,IPLOCX,IRLOCX,IHLOCX) integer :: NPX,NRX,NHX,MKX,IPLOCX(MKX),IRLOCX(MKX),IHLOCX(MKX) integer :: IPMAX,IP,IP1,IRMAX,IR,IR1,IH1,IH,IHMAX,I @@ -549,31 +549,31 @@ SUBROUTINE LOCX(PNX,RNX,HNX,NPX,NRX,NHX,MKX, & DO 10 I = 1,IPMAX IP1 = IP+1 PNOW = (FLOAT(I)-PLX)/100.0 - IF(PNOW>=PNX(IP1)) IP = IP1 + if (PNOW>=PNX(IP1)) IP = IP1 IPLOCX(I)= IP -10 CONTINUE +10 continue RLX = 1.0-RNX(1)*100.0 IRMAX = IDNINT(RNX(NRX)*100.0+RLX) IR = 1 DO 20 I = 1,IRMAX IR1 = IR+1 RNOW = (FLOAT(I)-RLX)/100.0 - IF(RNOW>=RNX(IR1)) IR = IR1 + if (RNOW>=RNX(IR1)) IR = IR1 IRLOCX(I)= IR -20 CONTINUE +20 continue HLX = 1.0-HNX(1) IHMAX = IDNINT(HNX(NHX)+HLX) IH = 1 DO 30 I = 1,IHMAX IH1 = IH+1 HNOW = FLOAT(I)-HLX - IF(HNOW>=HNX(IH1)) IH = IH1 + if (HNOW>=HNX(IH1)) IH = IH1 IHLOCX(I)= IH -30 CONTINUE +30 continue RETURN END - SUBROUTINE VEL3(PE,RE,HE,V,LAY,JP3DM_V) + subroutine VEL3(PE,RE,HE,V,LAY,JP3DM_V) implicit none include "constants.h" @@ -652,10 +652,10 @@ SUBROUTINE VEL3(PE,RE,HE,V,LAY,JP3DM_V) JP3DM_V%P = 90.0-PE/DEGREES_TO_RADIANS JP3DM_V%R = RE/DEGREES_TO_RADIANS JP3DM_V%H = HE - IF(LAY<=3) THEN + if (LAY<=3) then CALL PRHF(JP3DM_V%IPLOCA,JP3DM_V%IRLOCA,JP3DM_V%IHLOCA,JP3DM_V%PLA,JP3DM_V%RLA,JP3DM_V%HLA, & JP3DM_V%PNA,JP3DM_V%RNA,JP3DM_V%HNA,MPA,MRA,MHA,MKA,JP3DM_V) - ELSE IF(LAY==4) THEN + ELSE if (LAY==4) then CALL PRHF(JP3DM_V%IPLOCB,JP3DM_V%IRLOCB,JP3DM_V%IHLOCB,JP3DM_V%PLB,JP3DM_V%RLB,JP3DM_V%HLB, & JP3DM_V%PNB,JP3DM_V%RNB,JP3DM_V%HNB,MPB,MRB,MHB,MKB,JP3DM_V) ELSE @@ -669,17 +669,17 @@ SUBROUTINE VEL3(PE,RE,HE,V,LAY,JP3DM_V) JP3DM_V%WV(7) = JP3DM_V%PF1*JP3DM_V%RF*JP3DM_V%HF JP3DM_V%WV(8) = JP3DM_V%PF*JP3DM_V%RF*JP3DM_V%HF ! calculate velocity - IF(LAY<=3) THEN + if (LAY<=3) then CALL VABPS(MPA,MRA,MHA,JP3DM_V%VELAP,V,JP3DM_V) - ELSE IF(LAY==4) THEN + ELSE if (LAY==4) then CALL VABPS(MPB,MRB,MHB,JP3DM_V%VELBP,V,JP3DM_V) ELSE endif RETURN - END SUBROUTINE VEL3 + end subroutine VEL3 - SUBROUTINE VABPS(MP,MR,MH,V,VEL,JP3DM_V) + subroutine VABPS(MP,MR,MH,V,VEL,JP3DM_V) implicit none include "constants.h" @@ -762,7 +762,7 @@ SUBROUTINE VABPS(MP,MR,MH,V,VEL,JP3DM_V) RETURN END - SUBROUTINE INTMAP(R,IRLOC,NNR,RL,IR) + subroutine INTMAP(R,IRLOC,NNR,RL,IR) integer :: NNR,IRLOC(NNR),IS,IR double precision :: R,RL IS = IDNINT(R+RL) @@ -770,7 +770,7 @@ SUBROUTINE INTMAP(R,IRLOC,NNR,RL,IR) RETURN END - SUBROUTINE PRHF(IPLOCX,IRLOCX,IHLOCX,PLX,RLX,HLX, & + subroutine PRHF(IPLOCX,IRLOCX,IHLOCX,PLX,RLX,HLX, & PNX,RNX,HNX,MPX,MRX,MHX,MKX,JP3DM_V) implicit none @@ -869,7 +869,7 @@ SUBROUTINE PRHF(IPLOCX,IRLOCX,IHLOCX,PLX,RLX,HLX, & RETURN END - SUBROUTINE HLAY(PE,RE,HE,IJK,JP3DM_V) + subroutine HLAY(PE,RE,HE,IJK,JP3DM_V) implicit none include "constants.h" @@ -948,14 +948,14 @@ SUBROUTINE HLAY(PE,RE,HE,IJK,JP3DM_V) CALL LIMIT(JP3DM_V%RRN(1),JP3DM_V%RRN(63),R) DO 1 I = 1,50 I1 = I+1 - IF(P>=JP3DM_V%PN(I).and.P=JP3DM_V%PN(I).and.P=JP3DM_V%RRN(J).and.R=JP3DM_V%RRN(J).and.RA2) C = A2 - END SUBROUTINE LIMIT + if (CA2) C = A2 + end subroutine LIMIT - SUBROUTINE VEL1D(HE,V,LAY,IPS,JP3DM_V) + subroutine VEL1D(HE,V,LAY,IPS,JP3DM_V) implicit none include "constants.h" @@ -1060,15 +1060,15 @@ SUBROUTINE VEL1D(HE,V,LAY,IPS,JP3DM_V) integer :: IPS,LAY double precision :: HE,V,VM,HM - IF(LAY==1) THEN + if (LAY==1) then V = 6.0 - IF(IPS==2) V = 3.5 - ELSE IF(LAY==2) THEN + if (IPS==2) V = 3.5 + ELSE if (LAY==2) then V = 6.7 - IF(IPS==2) V = 3.8 - ELSE IF(LAY>=3) THEN + if (IPS==2) V = 3.8 + ELSE if (LAY>=3) then HM = 40.0 - IF(HE=H1.and.H=H1.and.H= 1.0d0-tol) s=1.0d0-tol + if (s >= 1.0d0-tol) s=1.0d0-tol lsave=l - if(l<0) l=-1-l - if(l>0) goto 1 + if (l<0) l=-1-l + if (l>0) goto 1 x(1)=rfpi dx(1)=0.0d0 l=lsave return - 1 if(l /= 1) goto 2 + 1 if (l /= 1) goto 2 c1=sqroot3*rfpi c2=sqroot2over2*c1 x(1)=c1*c @@ -78,7 +78,7 @@ subroutine lgndr(l,c,s,x,dx) l=lsave return 2 sos=s - if(s=r_moho .or. radius <= r_cmb) return + if (radius>=r_moho .or. radius <= r_cmb) return xr=-1.0d0+2.0d0*(radius-r_cmb)/(r_moho-r_cmb) do k=0,NK @@ -220,7 +220,7 @@ subroutine splhsetup(D3MM_V)!!!!!!!!!!!!!!(spknt,qq0,qq) do i=1,NK+1 do j=1,NK+1 - if(i == j) then + if (i == j) then D3MM_V%qq0(j,i)=1.0d0 else D3MM_V%qq0(j,i)=0.0d0 @@ -262,48 +262,48 @@ double precision function rsple(I1,I2,X,Y,Q,S) I=MIN0(I,II) ! SEE IF X IS INCREASING OR DECREASING. - IF(X(I2)-X(I1) < 0) goto 1 - IF(X(I2)-X(I1) >= 0) goto 2 + if (X(I2)-X(I1) < 0) goto 1 + if (X(I2)-X(I1) >= 0) goto 2 ! X IS DECREASING. CHANGE I AS NECESSARY. - 1 IF(S-X(I) <= 0) goto 3 - IF(S-X(I) > 0) goto 4 + 1 if (S-X(I) <= 0) goto 3 + if (S-X(I) > 0) goto 4 4 I=I-1 - IF(I-I1 < 0) goto 11 - IF(I-I1 == 0) goto 6 - IF(I-I1 > 0) goto 1 + if (I-I1 < 0) goto 11 + if (I-I1 == 0) goto 6 + if (I-I1 > 0) goto 1 - 3 IF(S-X(I+1) < 0) goto 5 - IF(S-X(I+1) >= 0) goto 6 + 3 if (S-X(I+1) < 0) goto 5 + if (S-X(I+1) >= 0) goto 6 5 I=I+1 - IF(I-II < 0) goto 3 - IF(I-II == 0) goto 6 - IF(I-II > 0) goto 7 + if (I-II < 0) goto 3 + if (I-II == 0) goto 6 + if (I-II > 0) goto 7 ! X IS INCREASING. CHANGE I AS NECESSARY. - 2 IF(S-X(I+1) <= 0) goto 8 - IF(S-X(I+1) > 0) goto 9 + 2 if (S-X(I+1) <= 0) goto 8 + if (S-X(I+1) > 0) goto 9 9 I=I+1 - IF(I-II < 0) goto 2 - IF(I-II == 0) goto 6 - IF(I-II > 0) goto 7 + if (I-II < 0) goto 2 + if (I-II == 0) goto 6 + if (I-II > 0) goto 7 - 8 IF(S-X(I) < 0) goto 10 - IF(S-X(I) >= 0) goto 6 + 8 if (S-X(I) < 0) goto 10 + if (S-X(I) >= 0) goto 6 10 I=I-1 - IF(I-I1 < 0) goto 11 - IF(I-I1 == 0) goto 6 - IF(I-I1 > 0) goto 8 + if (I-I1 < 0) goto 11 + if (I-I1 == 0) goto 6 + if (I-I1 > 0) goto 8 7 I=II - GOTO 6 + goto 6 11 I=I1 ! CALCULATE RSPLE USING SPLINE COEFFICIENTS IN Y AND Q. @@ -318,7 +318,7 @@ subroutine rspln(I1,I2,X,Y,Q,F) implicit none -! Subroutine rspln computes cubic spline interpolation coefficients +! subroutine rspln computes cubic spline interpolation coefficients ! for y(x) between grid points i1 and i2 saving them in q.The ! interpolation is continuous with continuous first and second ! derivatives. It agrees exactly with y at grid points and with the @@ -342,26 +342,26 @@ subroutine rspln(I1,I2,X,Y,Q,F) Y0=0.0d0 ! BAIL OUT IF THERE ARE LESS THAN TWO POINTS TOTAL - IF(I2-I1 < 0) return - IF(I2-I1 == 0) goto 17 - IF(I2-I1 > 0) goto 8 + if (I2-I1 < 0) return + if (I2-I1 == 0) goto 17 + if (I2-I1 > 0) goto 8 8 A0=X(J1-1) ! SEARCH FOR DISCONTINUITIES. DO 3 I=J1,I2 B0=A0 A0=X(I) - IF(DABS((A0-B0)/DMAX1(A0,B0)) < SMALL) GOTO 4 - 3 CONTINUE + if (DABS((A0-B0)/DMAX1(A0,B0)) < SMALL) goto 4 + 3 continue 17 J1=J1-1 J2=I2-2 - GOTO 5 + goto 5 4 J1=J1-1 J2=I-3 ! SEE IF THERE ARE ENOUGH POINTS TO INTERPOLATE (AT LEAST THREE). - 5 IF(J2+1-J1 < 0) goto 9 - IF(J2+1-J1 == 0) goto 10 - IF(J2+1-J1 > 0) goto 11 + 5 if (J2+1-J1 < 0) goto 9 + if (J2+1-J1 == 0) goto 10 + if (J2+1-J1 > 0) goto 11 ! ONLY TWO POINTS. USE LINEAR INTERPOLATION. 10 J2=J2+2 @@ -370,7 +370,7 @@ subroutine rspln(I1,I2,X,Y,Q,F) Q(J,J1)=YY(J) Q(J,J2)=YY(J) enddo - GOTO 12 + goto 12 ! MORE THAN TWO POINTS. DO SPLINE INTERPOLATION. 11 A0=0. @@ -437,7 +437,7 @@ subroutine rspln(I1,I2,X,Y,Q,F) enddo ! SEE IF THIS DISCONTINUITY IS THE LAST. - 12 IF(J2-I2 < 0) then + 12 if (J2-I2 < 0) then goto 6 else return @@ -445,8 +445,8 @@ subroutine rspln(I1,I2,X,Y,Q,F) ! NO. GO BACK FOR MORE. 6 J1=J2+2 - IF(J1-I2 <= 0) goto 8 - IF(J1-I2 > 0) goto 7 + if (J1-I2 <= 0) goto 8 + if (J1-I2 > 0) goto 7 ! THERE IS ONLY ONE POINT LEFT AFTER THE LATEST DISCONTINUITY. 7 DO J=1,3 diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/memory_eval.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/memory_eval.f90 index 8d6fb65ee..882a2ca00 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/memory_eval.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/memory_eval.f90 @@ -88,9 +88,9 @@ subroutine memory_eval(OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MA ! count anisotropic elements do ilayer = 1, NUMBER_OF_MESH_LAYERS - if(doubling_index(ilayer) == IFLAG_220_80 .or. doubling_index(ilayer) == IFLAG_80_MOHO) then + if (doubling_index(ilayer) == IFLAG_220_80 .or. doubling_index(ilayer) == IFLAG_80_MOHO) then ner_without_doubling = ner(ilayer) - if(this_region_has_a_doubling(ilayer)) then + if (this_region_has_a_doubling(ilayer)) then ner_without_doubling = ner_without_doubling - 2 ispec_aniso = ispec_aniso + & (NSPEC_DOUBLING_SUPERBRICK*(NEX_PER_PROC_XI/ratio_sampling_array(ilayer)/2)* & @@ -103,20 +103,20 @@ subroutine memory_eval(OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MA ! define static size of the arrays whose size depends on logical tests - if(ANISOTROPIC_INNER_CORE) then + if (ANISOTROPIC_INNER_CORE) then NSPECMAX_ANISO_IC = NSPEC(IREGION_INNER_CORE) else NSPECMAX_ANISO_IC = 1 endif - if(ANISOTROPIC_3D_MANTLE) then + if (ANISOTROPIC_3D_MANTLE) then NSPECMAX_ISO_MANTLE = 1 NSPECMAX_TISO_MANTLE = 1 NSPECMAX_ANISO_MANTLE = NSPEC(IREGION_CRUST_MANTLE) else NSPECMAX_ISO_MANTLE = NSPEC(IREGION_CRUST_MANTLE) - if(TRANSVERSE_ISOTROPY) then + if (TRANSVERSE_ISOTROPY) then NSPECMAX_TISO_MANTLE = ispec_aniso else NSPECMAX_TISO_MANTLE = 1 @@ -126,7 +126,7 @@ subroutine memory_eval(OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MA endif ! if attenuation is off, set dummy size of arrays to one - if(ATTENUATION) then + if (ATTENUATION) then NSPEC_CRUST_MANTLE_ATTENUAT = NSPEC(IREGION_CRUST_MANTLE) NSPEC_INNER_CORE_ATTENUATION = NSPEC(IREGION_INNER_CORE) else @@ -134,7 +134,7 @@ subroutine memory_eval(OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MA NSPEC_INNER_CORE_ATTENUATION = 1 endif - if(ATTENUATION .or. SIMULATION_TYPE /= 1 .or. SAVE_FORWARD .or. (MOVIE_VOLUME .and. SIMULATION_TYPE /= 3)) then + if (ATTENUATION .or. SIMULATION_TYPE /= 1 .or. SAVE_FORWARD .or. (MOVIE_VOLUME .and. SIMULATION_TYPE /= 3)) then NSPEC_CRUST_MANTLE_STR_OR_ATT = NSPEC(IREGION_CRUST_MANTLE) NSPEC_INNER_CORE_STR_OR_ATT = NSPEC(IREGION_INNER_CORE) else @@ -142,7 +142,7 @@ subroutine memory_eval(OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MA NSPEC_INNER_CORE_STR_OR_ATT = 1 endif - if(ATTENUATION .and. SIMULATION_TYPE == 3) then + if (ATTENUATION .and. SIMULATION_TYPE == 3) then NSPEC_CRUST_MANTLE_STR_AND_ATT = NSPEC(IREGION_CRUST_MANTLE) NSPEC_INNER_CORE_STR_AND_ATT = NSPEC(IREGION_INNER_CORE) else @@ -151,7 +151,7 @@ subroutine memory_eval(OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MA endif - if(SIMULATION_TYPE /= 1 .or. SAVE_FORWARD .or. (MOVIE_VOLUME .and. SIMULATION_TYPE /= 3)) then + if (SIMULATION_TYPE /= 1 .or. SAVE_FORWARD .or. (MOVIE_VOLUME .and. SIMULATION_TYPE /= 3)) then NSPEC_CRUST_MANTLE_STRAIN_ONLY = NSPEC(IREGION_CRUST_MANTLE) NSPEC_INNER_CORE_STRAIN_ONLY = NSPEC(IREGION_INNER_CORE) else @@ -168,7 +168,7 @@ subroutine memory_eval(OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MA NGLOB_OUTER_CORE_ADJOINT = NGLOB(IREGION_OUTER_CORE) NGLOB_INNER_CORE_ADJOINT = NGLOB(IREGION_INNER_CORE) - if(ROTATION) then + if (ROTATION) then NSPEC_OUTER_CORE_ROT_ADJOINT = NSPEC(IREGION_OUTER_CORE) else NSPEC_OUTER_CORE_ROT_ADJOINT = 1 @@ -186,7 +186,7 @@ subroutine memory_eval(OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MA endif ! if absorbing conditions are off, set dummy size of arrays to one - if(ABSORBING_CONDITIONS) then + if (ABSORBING_CONDITIONS) then NSPEC_CRUST_MANTLE_STACEY = NSPEC(IREGION_CRUST_MANTLE) NSPEC_OUTER_CORE_STACEY = NSPEC(IREGION_OUTER_CORE) else @@ -195,13 +195,13 @@ subroutine memory_eval(OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MA endif ! if oceans are off, set dummy size of arrays to one - if(OCEANS) then + if (OCEANS) then NGLOB_CRUST_MANTLE_OCEANS = NGLOB(IREGION_CRUST_MANTLE) else NGLOB_CRUST_MANTLE_OCEANS = 1 endif - if(ROTATION) then + if (ROTATION) then NSPEC_OUTER_CORE_ROTATION = NSPEC(IREGION_OUTER_CORE) else NSPEC_OUTER_CORE_ROTATION = 1 @@ -288,7 +288,7 @@ subroutine memory_eval(OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MA ! A_array_rotation,B_array_rotation ! static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_OUTER_CORE_ROTATION*2.d0*dble(CUSTOM_REAL) -! if(ABSORBING_CONDITIONS) then +! if (ABSORBING_CONDITIONS) then ! rho_vp_crust_mantle,rho_vs_crust_mantle ! static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_CRUST_MANTLE)*2.d0*dble(CUSTOM_REAL) @@ -298,7 +298,7 @@ subroutine memory_eval(OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MA ! endif -! if(OCEANS) then +! if (OCEANS) then ! rmass_ocean_load ! static_memory_size = static_memory_size + NGLOB(IREGION_CRUST_MANTLE)*dble(CUSTOM_REAL) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/meshfem3D.F90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/meshfem3D.F90 index 1d60bdff7..1e5c41d7d 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/meshfem3D.F90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/meshfem3D.F90 @@ -561,7 +561,7 @@ program xmeshfem3D call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES') ! open main output file, only written to by process 0 - if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) & + if (myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) & open(unit=IMAIN,file=trim(OUTPUT_FILES)//'/output_mesher.txt',status='unknown') ! get MPI starting time @@ -571,7 +571,7 @@ program xmeshfem3D time_start = 0 #endif - if(myrank == 0) then + if (myrank == 0) then write(IMAIN,*) write(IMAIN,*) '****************************' write(IMAIN,*) '*** Specfem3D MPI Mesher ***' @@ -613,7 +613,7 @@ program xmeshfem3D DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,& WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.) - if(err_occurred() /= 0) then + if (err_occurred() /= 0) then call exit_MPI(myrank,'an error occurred while reading the parameter file') endif @@ -793,7 +793,7 @@ program xmeshfem3D ! check that the code is running with the requested number of processes #ifdef USE_MPI - if(sizeprocs /= NPROCTOT) then + if (sizeprocs /= NPROCTOT) then print *,'myrank,sizeprocs,NPROCTOT = ',myrank,sizeprocs,NPROCTOT call exit_MPI(myrank,'wrong number of MPI processes') endif @@ -811,7 +811,7 @@ program xmeshfem3D iproc_eta_slice(:) = 0 ! loop on all the chunks to create global slice addressing for solver - if(myrank == 0) then + if (myrank == 0) then open(unit=IOUT,file='../DATABASES_FOR_SOLVER/addressing.txt',status='unknown') write(IMAIN,*) 'creating global slice addressing' write(IMAIN,*) @@ -824,13 +824,13 @@ program xmeshfem3D ichunk_slice(iprocnum) = ichunk iproc_xi_slice(iprocnum) = iproc_xi iproc_eta_slice(iprocnum) = iproc_eta - if(myrank == 0) write(IOUT,*) iprocnum - if(myrank == 0) write(IOUT,*) iproc_xi - if(myrank == 0) write(IOUT,*) iproc_eta + if (myrank == 0) write(IOUT,*) iprocnum + if (myrank == 0) write(IOUT,*) iproc_xi + if (myrank == 0) write(IOUT,*) iproc_eta enddo enddo enddo - if(myrank == 0) close(IOUT) + if (myrank == 0) close(IOUT) ! this for the different counters (which are now different if the superbrick is cut in the outer core) do iregion=1,MAX_NUM_REGIONS @@ -896,7 +896,7 @@ program xmeshfem3D endif endif - if(myrank == 0) then + if (myrank == 0) then write(IMAIN,*) 'This is process ',myrank write(IMAIN,*) 'There are ',sizeprocs,' MPI processes' write(IMAIN,*) 'Processes are numbered from 0 to ',sizeprocs-1 @@ -921,74 +921,74 @@ program xmeshfem3D write(IMAIN,*) endif - if(myrank == 0) then + if (myrank == 0) then write(IMAIN,*) - if(ELLIPTICITY) then + if (ELLIPTICITY) then write(IMAIN,*) 'incorporating ellipticity' else write(IMAIN,*) 'no ellipticity' endif write(IMAIN,*) - if(TOPOGRAPHY) then + if (TOPOGRAPHY) then write(IMAIN,*) 'incorporating surface topography' else write(IMAIN,*) 'no surface topography' endif write(IMAIN,*) - if(ISOTROPIC_3D_MANTLE) then + if (ISOTROPIC_3D_MANTLE) then write(IMAIN,*) 'incorporating 3-D lateral variations' else write(IMAIN,*) 'no 3-D lateral variations' endif write(IMAIN,*) - if(CRUSTAL) then + if (CRUSTAL) then write(IMAIN,*) 'incorporating crustal variations' else write(IMAIN,*) 'no crustal variations' endif write(IMAIN,*) - if(ONE_CRUST) then + if (ONE_CRUST) then write(IMAIN,*) 'using one layer only in PREM crust' else write(IMAIN,*) 'using unmodified 1D crustal model with two layers' endif write(IMAIN,*) - if(GRAVITY) then + if (GRAVITY) then write(IMAIN,*) 'incorporating self-gravitation (Cowling approximation)' else write(IMAIN,*) 'no self-gravitation' endif write(IMAIN,*) - if(ROTATION) then + if (ROTATION) then write(IMAIN,*) 'incorporating rotation' else write(IMAIN,*) 'no rotation' endif write(IMAIN,*) - if(TRANSVERSE_ISOTROPY) then + if (TRANSVERSE_ISOTROPY) then write(IMAIN,*) 'incorporating anisotropy' else write(IMAIN,*) 'no anisotropy' endif write(IMAIN,*) - if(ATTENUATION) then + if (ATTENUATION) then write(IMAIN,*) 'incorporating attenuation using ',N_SLS,' standard linear solids' - if(ATTENUATION_3D) write(IMAIN,*)'using 3D attenuation' + if (ATTENUATION_3D) write(IMAIN,*)'using 3D attenuation' else write(IMAIN,*) 'no attenuation' endif write(IMAIN,*) - if(OCEANS) then + if (OCEANS) then write(IMAIN,*) 'incorporating the oceans using equivalent load' else write(IMAIN,*) 'no oceans' @@ -997,13 +997,13 @@ program xmeshfem3D write(IMAIN,*) endif - if(ELLIPTICITY) call make_ellipticity(nspl,rspl,espl,espl2,ONE_CRUST) + if (ELLIPTICITY) call make_ellipticity(nspl,rspl,espl,espl2,ONE_CRUST) - if(ISOTROPIC_3D_MANTLE) then - if(THREE_D_MODEL /= 0) call read_smooth_moho - if(THREE_D_MODEL == THREE_D_MODEL_S20RTS) then + if (ISOTROPIC_3D_MANTLE) then + if (THREE_D_MODEL /= 0) call read_smooth_moho + if (THREE_D_MODEL == THREE_D_MODEL_S20RTS) then ! the variables read are declared and stored in structure D3MM_V - if(myrank == 0) call read_mantle_model(D3MM_V) + if (myrank == 0) call read_mantle_model(D3MM_V) ! broadcast the information read on the master to the nodes #ifdef USE_MPI call MPI_BCAST(D3MM_V%dvs_a,(NK+1)*(NS+1)*(NS+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier) @@ -1014,9 +1014,9 @@ program xmeshfem3D call MPI_BCAST(D3MM_V%qq0,(NK+1)*(NK+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier) call MPI_BCAST(D3MM_V%qq,3*(NK+1)*(NK+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier) #endif - else if(THREE_D_MODEL == THREE_D_MODEL_SEA99_JP3D) then + else if (THREE_D_MODEL == THREE_D_MODEL_SEA99_JP3D) then ! the variables read are declared and stored in structure SEA99M_V and JP3DM_V - if(myrank == 0) then + if (myrank == 0) then call read_sea99_s_model(SEA99M_V) call read_iso3d_dpzhao_model(JP3DM_V) endif @@ -1089,9 +1089,9 @@ program xmeshfem3D call MPI_BCAST(JP3DM_V%RA,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier) call MPI_BCAST(JP3DM_V%DEPJ,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier) #endif - else if(THREE_D_MODEL == THREE_D_MODEL_SEA99) then + else if (THREE_D_MODEL == THREE_D_MODEL_SEA99) then ! the variables read are declared and stored in structure SEA99M_V - if(myrank == 0) call read_sea99_s_model(SEA99M_V) + if (myrank == 0) call read_sea99_s_model(SEA99M_V) ! broadcast the information read on the master to the nodes ! SEA99M_V #ifdef USE_MPI @@ -1106,9 +1106,9 @@ program xmeshfem3D call MPI_BCAST(SEA99M_V%sea99_vs,100*100*100,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier) call MPI_BCAST(SEA99M_V%sea99_depth,100,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier) #endif - else if(THREE_D_MODEL == THREE_D_MODEL_JP3D) then + else if (THREE_D_MODEL == THREE_D_MODEL_JP3D) then ! the variables read are declared and stored in structure JP3DM_V - if(myrank == 0) call read_iso3d_dpzhao_model(JP3DM_V) + if (myrank == 0) call read_iso3d_dpzhao_model(JP3DM_V) ! JP3DM_V #ifdef USE_MPI call MPI_BCAST(JP3DM_V%NPA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier) @@ -1166,9 +1166,9 @@ program xmeshfem3D call MPI_BCAST(JP3DM_V%RA,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier) call MPI_BCAST(JP3DM_V%DEPJ,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier) #endif - else if(THREE_D_MODEL == THREE_D_MODEL_S362ANI .or. THREE_D_MODEL == THREE_D_MODEL_S362WMANI & + else if (THREE_D_MODEL == THREE_D_MODEL_S362ANI .or. THREE_D_MODEL == THREE_D_MODEL_S362WMANI & .or. THREE_D_MODEL == THREE_D_MODEL_S362ANI_PREM .or. THREE_D_MODEL == THREE_D_MODEL_S29EA) then - if(myrank == 0) call read_model_s362ani(THREE_D_MODEL,THREE_D_MODEL_S362ANI,THREE_D_MODEL_S362WMANI, & + if (myrank == 0) call read_model_s362ani(THREE_D_MODEL,THREE_D_MODEL_S362ANI,THREE_D_MODEL_S362WMANI, & THREE_D_MODEL_S362ANI_PREM,THREE_D_MODEL_S29EA, & numker,numhpa,ihpa,lmxhpa,itypehpa,ihpakern,numcoe,ivarkern,itpspl, & xlaspl,xlospl,radspl,coe,hsplfl,dskker,kerstr,varstr,refmdl) @@ -1200,9 +1200,9 @@ program xmeshfem3D endif endif - if(ANISOTROPIC_3D_MANTLE) then + if (ANISOTROPIC_3D_MANTLE) then ! the variables read are declared and stored in structure AMM_V - if(myrank == 0) call read_aniso_mantle_model(AMM_V) + if (myrank == 0) call read_aniso_mantle_model(AMM_V) ! broadcast the information read on the master to the nodes #ifdef USE_MPI call MPI_BCAST(AMM_V%npar1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier) @@ -1211,9 +1211,9 @@ program xmeshfem3D #endif endif - if(CRUSTAL) then + if (CRUSTAL) then ! the variables read are declared and stored in structure CM_V - if(myrank == 0) call read_crustal_model(CM_V) + if (myrank == 0) call read_crustal_model(CM_V) ! broadcast the information read on the master to the nodes #ifdef USE_MPI call MPI_BCAST(CM_V%thlr,NKEYS_CRUST*NLAYERS_CRUST,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier) @@ -1225,16 +1225,16 @@ program xmeshfem3D #endif endif - if(ANISOTROPIC_INNER_CORE) then - if(myrank == 0) call read_aniso_inner_core_model + if (ANISOTROPIC_INNER_CORE) then + if (myrank == 0) call read_aniso_inner_core_model ! one should add an MPI_BCAST here if one adds a read_aniso_inner_core_model subroutine endif - if(ATTENUATION .and. ATTENUATION_3D) then + if (ATTENUATION .and. ATTENUATION_3D) then !! DK DK removed attenuation for MPI + GPU version -!! DK DK if(myrank == 0) call read_attenuation_model(MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD, AM_V) +!! DK DK if (myrank == 0) call read_attenuation_model(MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD, AM_V) - if(myrank /= 0) allocate(AM_V%Qtau_s(N_SLS)) + if (myrank /= 0) allocate(AM_V%Qtau_s(N_SLS)) #ifdef USE_MPI call MPI_BCAST(AM_V%min_period, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier) call MPI_BCAST(AM_V%max_period, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier) @@ -1245,10 +1245,10 @@ program xmeshfem3D #endif endif - if(ATTENUATION .and. .not. ATTENUATION_3D) then + if (ATTENUATION .and. .not. ATTENUATION_3D) then !! DK DK removed attenuation for MPI + GPU version -!! DK DK if(myrank == 0) call read_attenuation_model(MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD, AM_V) +!! DK DK if (myrank == 0) call read_attenuation_model(MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD, AM_V) #ifdef USE_MPI call MPI_BCAST(AM_V%min_period, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier) @@ -1261,8 +1261,8 @@ program xmeshfem3D endif ! read topography and bathymetry file - if(TOPOGRAPHY .or. OCEANS) then - if(myrank == 0) call read_topo_bathy_file(ibathy_topo) + if (TOPOGRAPHY .or. OCEANS) then + if (myrank == 0) call read_topo_bathy_file(ibathy_topo) ! broadcast the information read on the master to the nodes #ifdef USE_MPI call MPI_BCAST(ibathy_topo,NX_BATHY*NY_BATHY,MPI_INTEGER,0,MPI_COMM_WORLD,ier) @@ -1274,7 +1274,7 @@ program xmeshfem3D iproc_xi = iproc_xi_slice(myrank) iproc_eta = iproc_eta_slice(myrank) - if(myrank == 0) then + if (myrank == 0) then write(IMAIN,*) 'Reference radius of the Earth used is ',R_EARTH_KM,' km' write(IMAIN,*) write(IMAIN,*) 'Central cube is at a radius of ',R_CENTRAL_CUBE/1000.d0,' km' @@ -1283,7 +1283,7 @@ program xmeshfem3D ! compute rotation matrix from Euler angles ANGULAR_WIDTH_XI_RAD = ANGULAR_WIDTH_XI_IN_DEGREES * PI / 180.d0 ANGULAR_WIDTH_ETA_RAD = ANGULAR_WIDTH_ETA_IN_DEGREES * PI / 180.d0 - if(NCHUNKS /= 6) call euler_angles(rotation_matrix,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH) + if (NCHUNKS /= 6) call euler_angles(rotation_matrix,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH) ! volume of the slice volume_total = ZERO @@ -1302,7 +1302,7 @@ program xmeshfem3D !! DK DK use only the crust_mantle region for the GPU + MPI code do iregion_code = 1,1 - if(myrank == 0) then + if (myrank == 0) then write(IMAIN,*) write(IMAIN,*) '*******************************************' write(IMAIN,*) 'creating mesh in region ',iregion_code @@ -1370,10 +1370,10 @@ program xmeshfem3D enddo ! store number of anisotropic elements found in the mantle - if(nspec_aniso /= 0 .and. iregion_code /= IREGION_CRUST_MANTLE) & + if (nspec_aniso /= 0 .and. iregion_code /= IREGION_CRUST_MANTLE) & call exit_MPI(myrank,'found anisotropic elements outside of the mantle') - if(iregion_code == IREGION_CRUST_MANTLE .and. nspec_aniso == 0) & + if (iregion_code == IREGION_CRUST_MANTLE .and. nspec_aniso == 0) & call exit_MPI(myrank,'found no anisotropic elements in the mantle') ! use MPI reduction to compute total area and volume @@ -1386,7 +1386,7 @@ program xmeshfem3D #endif ! sum volume over all the regions - if(myrank == 0) volume_total = volume_total + volume_total_region + if (myrank == 0) volume_total = volume_total + volume_total_region ! deallocate arrays used for that region deallocate(idoubling) @@ -1404,14 +1404,14 @@ program xmeshfem3D ! end of loop on all the regions enddo - if(myrank == 0) then + if (myrank == 0) then ! check volume of chunk write(IMAIN,*) write(IMAIN,*) 'calculated volume: ',volume_total - if(.not. TOPOGRAPHY) then + if (.not. TOPOGRAPHY) then ! take the central cube into account ! it is counted 6 times because of the fictitious elements -! if(INCLUDE_CENTRAL_CUBE) then +! if (INCLUDE_CENTRAL_CUBE) then ! write(IMAIN,*) ' exact volume: ', & ! dble(NCHUNKS)*((4.0d0/3.0d0)*PI*(R_UNIT_SPHERE**3)+5.*(2.*(R_CENTRAL_CUBE/R_EARTH)/sqrt(3.))**3)/6.d0 ! else @@ -1427,7 +1427,7 @@ program xmeshfem3D !--- print number of points and elements in the mesh for each region - if(myrank == 0) then + if (myrank == 0) then numelem_crust_mantle = NSPEC(IREGION_CRUST_MANTLE) numelem_outer_core = NSPEC(IREGION_OUTER_CORE) @@ -1458,7 +1458,7 @@ program xmeshfem3D write(IMAIN,*) ! write information about precision used for floating-point operations - if(CUSTOM_REAL == SIZE_REAL) then + if (CUSTOM_REAL == SIZE_REAL) then write(IMAIN,*) 'using single precision for the calculations' else write(IMAIN,*) 'using double precision for the calculations' @@ -1521,7 +1521,7 @@ program xmeshfem3D deallocate(iproc_eta_slice) ! elapsed time since beginning of mesh generation - if(myrank == 0) then + if (myrank == 0) then #ifdef USE_MPI tCPU = MPI_WTIME() - time_start #else diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_1066a.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_1066a.f90 index 784eb6c4c..5aed4599a 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_1066a.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_1066a.f90 @@ -74,14 +74,14 @@ subroutine model_1066a(x,rho,vp,vs,Qkappa,Qmu,iregion_code,M1066a_V) ! and a point below the ICB or the CMB and interpolate between them, ! which would lead to a wrong value (keeping in mind that we interpolate ! between points i-1 and i below) - if(iregion_code == IREGION_INNER_CORE .and. i > 33) i = 33 + if (iregion_code == IREGION_INNER_CORE .and. i > 33) i = 33 - if(iregion_code == IREGION_OUTER_CORE .and. i < 35) i = 35 - if(iregion_code == IREGION_OUTER_CORE .and. i > 66) i = 66 + if (iregion_code == IREGION_OUTER_CORE .and. i < 35) i = 35 + if (iregion_code == IREGION_OUTER_CORE .and. i > 66) i = 66 - if(iregion_code == IREGION_CRUST_MANTLE .and. i < 68) i = 68 + if (iregion_code == IREGION_CRUST_MANTLE .and. i < 68) i = 68 - if(i == 1) then + if (i == 1) then rho = M1066a_V%density_1066a(i) vp = M1066a_V%vp_1066a(i) vs = M1066a_V%vs_1066a(i) @@ -102,7 +102,7 @@ subroutine model_1066a(x,rho,vp,vs,Qkappa,Qmu,iregion_code,M1066a_V) ! make sure Vs is zero in the outer core even if roundoff errors on depth ! also set fictitious attenuation to a very high value (attenuation is not used in the fluid) - if(iregion_code == IREGION_OUTER_CORE) then + if (iregion_code == IREGION_OUTER_CORE) then vs = 0.d0 Qkappa = 3000.d0 Qmu = 3000.d0 @@ -1117,7 +1117,7 @@ subroutine define_model_1066a(USE_EXTERNAL_CRUSTAL_MODEL,M1066a_V) M1066a_V%Qmu_1066a(160) = 117.900000000000 ! strip the crust and replace it by mantle if we use an external crustal model - if(USE_EXTERNAL_CRUSTAL_MODEL) then + if (USE_EXTERNAL_CRUSTAL_MODEL) then do i=NR_1066A-3,NR_1066A M1066a_V%density_1066a(i) = M1066a_V%density_1066a(NR_1066A-4) M1066a_V%vp_1066a(i) = M1066a_V%vp_1066a(NR_1066A-4) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_ak135.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_ak135.f90 index 26640946b..2f6ffe724 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_ak135.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_ak135.f90 @@ -77,14 +77,14 @@ subroutine model_ak135(x,rho,vp,vs,Qkappa,Qmu,iregion_code,Mak135_V) ! and a point below the ICB or the CMB and interpolate between them, ! which would lead to a wrong value (keeping in mind that we interpolate ! between points i-1 and i below) - if(iregion_code == IREGION_INNER_CORE .and. i > 25) i = 25 + if (iregion_code == IREGION_INNER_CORE .and. i > 25) i = 25 - if(iregion_code == IREGION_OUTER_CORE .and. i < 27) i = 27 - if(iregion_code == IREGION_OUTER_CORE .and. i > 71) i = 71 + if (iregion_code == IREGION_OUTER_CORE .and. i < 27) i = 27 + if (iregion_code == IREGION_OUTER_CORE .and. i > 71) i = 71 - if(iregion_code == IREGION_CRUST_MANTLE .and. i < 73) i = 73 + if (iregion_code == IREGION_CRUST_MANTLE .and. i < 73) i = 73 - if(i == 1) then + if (i == 1) then rho = Mak135_V%density_ak135(i) vp = Mak135_V%vp_ak135(i) vs = Mak135_V%vs_ak135(i) @@ -105,7 +105,7 @@ subroutine model_ak135(x,rho,vp,vs,Qkappa,Qmu,iregion_code,Mak135_V) ! make sure Vs is zero in the outer core even if roundoff errors on depth ! also set fictitious attenuation to a very high value (attenuation is not used in the fluid) - if(iregion_code == IREGION_OUTER_CORE) then + if (iregion_code == IREGION_OUTER_CORE) then vs = 0.d0 Qkappa = 3000.d0 Qmu = 3000.d0 @@ -1024,7 +1024,7 @@ subroutine define_model_ak135(USE_EXTERNAL_CRUSTAL_MODEL,Mak135_V) Mak135_V%Qmu_ak135(144) = 599.990000000000 ! strip the crust and replace it by mantle - if(USE_EXTERNAL_CRUSTAL_MODEL) then + if (USE_EXTERNAL_CRUSTAL_MODEL) then do i=NR_AK135-8,NR_AK135 Mak135_V%density_ak135(i) = Mak135_V%density_ak135(NR_AK135-9) Mak135_V%vp_ak135(i) = Mak135_V%vp_ak135(NR_AK135-9) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_iasp91.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_iasp91.f90 index cb392f51c..1b07b49d6 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_iasp91.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_iasp91.f90 @@ -56,13 +56,13 @@ subroutine model_iasp91(myrank,x,rho,vp,vs,Qkappa,Qmu,idoubling,ONE_CRUST,check_ ! check flags to make sure we correctly honor the discontinuities ! we use strict inequalities since r has been slighly changed in mesher - if(check_doubling_flag) then + if (check_doubling_flag) then ! !--- inner core ! - if(r >= 0.d0 .and. r < RICB) then - if(idoubling /= IFLAG_INNER_CORE_NORMAL .and. & + if (r >= 0.d0 .and. r < RICB) then + if (idoubling /= IFLAG_INNER_CORE_NORMAL .and. & idoubling /= IFLAG_MIDDLE_CENTRAL_CUBE .and. & idoubling /= IFLAG_BOTTOM_CENTRAL_CUBE .and. & idoubling /= IFLAG_TOP_CENTRAL_CUBE .and. & @@ -71,34 +71,34 @@ subroutine model_iasp91(myrank,x,rho,vp,vs,Qkappa,Qmu,idoubling,ONE_CRUST,check_ ! !--- outer core ! - else if(r > RICB .and. r < RCMB) then - if(idoubling /= IFLAG_OUTER_CORE_NORMAL) & + else if (r > RICB .and. r < RCMB) then + if (idoubling /= IFLAG_OUTER_CORE_NORMAL) & call exit_MPI(myrank,'wrong doubling flag for outer core point') ! !--- D" at the base of the mantle ! - else if(r > RCMB .and. r < RTOPDDOUBLEPRIME) then - if(idoubling /= IFLAG_MANTLE_NORMAL) & + else if (r > RCMB .and. r < RTOPDDOUBLEPRIME) then + if (idoubling /= IFLAG_MANTLE_NORMAL) & call exit_MPI(myrank,'wrong doubling flag for D" point') ! !--- mantle: from top of D" to d670 ! - else if(r > RTOPDDOUBLEPRIME .and. r < R670) then - if(idoubling /= IFLAG_MANTLE_NORMAL) & + else if (r > RTOPDDOUBLEPRIME .and. r < R670) then + if (idoubling /= IFLAG_MANTLE_NORMAL) & call exit_MPI(myrank,'wrong doubling flag for top D" -> d670 point') ! !--- mantle: from d670 to d220 ! - else if(r > R670 .and. r < R220) then - if(idoubling /= IFLAG_670_220) & + else if (r > R670 .and. r < R220) then + if (idoubling /= IFLAG_670_220) & call exit_MPI(myrank,'wrong doubling flag for d670 -> d220 point') ! !--- mantle and crust: from d220 to MOHO and then to surface ! - else if(r > R220) then - if(idoubling /= IFLAG_220_80 .and. idoubling /= IFLAG_80_MOHO .and. idoubling /= IFLAG_CRUST) & + else if (r > R220) then + if (idoubling /= IFLAG_220_80 .and. idoubling /= IFLAG_80_MOHO .and. idoubling /= IFLAG_CRUST) & call exit_MPI(myrank,'wrong doubling flag for d220 -> Moho -> surface point') endif @@ -108,7 +108,7 @@ subroutine model_iasp91(myrank,x,rho,vp,vs,Qkappa,Qmu,idoubling,ONE_CRUST,check_ ! !--- inner core ! - if(r >= 0.d0 .and. r <= RICB) then + if (r >= 0.d0 .and. r <= RICB) then rho=13.0885d0-8.8381d0*x*x vp=11.24094-4.09689*x**2 vs=3.56454-3.45241*x**2 @@ -117,7 +117,7 @@ subroutine model_iasp91(myrank,x,rho,vp,vs,Qkappa,Qmu,idoubling,ONE_CRUST,check_ ! !--- outer core ! - else if(r > RICB .and. r <= RCMB) then + else if (r > RICB .and. r <= RCMB) then rho=12.5815d0-1.2638d0*x-3.6426d0*x*x-5.5281d0*x*x*x vp=10.03904+3.75665*x-13.67046*x**2 vs=0.0d0 @@ -126,7 +126,7 @@ subroutine model_iasp91(myrank,x,rho,vp,vs,Qkappa,Qmu,idoubling,ONE_CRUST,check_ ! !--- D" at the base of the mantle ! - else if(r > RCMB .and. r <= RTOPDDOUBLEPRIME) then + else if (r > RCMB .and. r <= RTOPDDOUBLEPRIME) then rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x vp=14.49470-1.47089*x vs=8.16616-1.58206*x @@ -136,13 +136,13 @@ subroutine model_iasp91(myrank,x,rho,vp,vs,Qkappa,Qmu,idoubling,ONE_CRUST,check_ ! !--- mantle: from top of D" to d670 ! - else if(r > RTOPDDOUBLEPRIME .and. r <= R771) then + else if (r > RTOPDDOUBLEPRIME .and. r <= R771) then rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x vp=25.1486-41.1538*x+51.9932*x**2-26.6083*x**3 vs=12.9303-21.2590*x+27.8988*x**2-14.1080*x**3 Qmu=312.0d0 Qkappa=57827.0d0 - else if(r > R771 .and. r <= R670) then + else if (r > R771 .and. r <= R670) then rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x vp=25.96984-16.93412*x vs=20.76890-16.53147*x @@ -151,13 +151,13 @@ subroutine model_iasp91(myrank,x,rho,vp,vs,Qkappa,Qmu,idoubling,ONE_CRUST,check_ ! !--- mantle: above d670 ! - else if(r > R670 .and. r <= R400) then + else if (r > R670 .and. r <= R400) then rho=5.3197d0-1.4836d0*x vp=29.38896-21.40656*x vs=17.70732-13.50652*x Qmu=143.0d0 Qkappa=57827.0d0 - else if(r > R400 .and. r <= R220) then + else if (r > R400 .and. r <= R220) then rho=7.1089d0-3.8045d0*x vp=30.78765-23.25415*x vs=15.24213-11.08552*x @@ -171,18 +171,18 @@ subroutine model_iasp91(myrank,x,rho,vp,vs,Qkappa,Qmu,idoubling,ONE_CRUST,check_ ! 35-120 6251-6336 8.78541-0.74953 x 6.706231-2.248585 x ! with x = r / 6371 - else if(r > R220 .and. r <= R120) then + else if (r > R220 .and. r <= R120) then rho=2.6910d0+0.6924d0*x vp=25.41389-17.69722*x vs=5.75020-1.27420*x Qmu=80.0d0 Qkappa=57827.0d0 - else if(r > R120 .and. r <= RMOHO) then + else if (r > R120 .and. r <= RMOHO) then vp = 8.78541d0-0.74953d0*x vs = 6.706231d0-2.248585d0*x rho = 3.3713d0 + (3.3198d0-3.3713d0)*(x-x1)/(x2-x1) - if(rho < 3.30d0 .or. rho > 3.38d0) stop 'incorrect density computed for IASP91' + if (rho < 3.30d0 .or. rho > 3.38d0) stop 'incorrect density computed for IASP91' Qmu=600.0d0 Qkappa=57827.0d0 @@ -194,7 +194,7 @@ subroutine model_iasp91(myrank,x,rho,vp,vs,Qkappa,Qmu,idoubling,ONE_CRUST,check_ Qmu=600.0d0 Qkappa=57827.0d0 - else if(r > RMOHO .and. r <= RMIDDLE_CRUST) then + else if (r > RMOHO .and. r <= RMIDDLE_CRUST) then vp = 6.5d0 vs = 3.75d0 rho = 2.92d0 @@ -202,7 +202,7 @@ subroutine model_iasp91(myrank,x,rho,vp,vs,Qkappa,Qmu,idoubling,ONE_CRUST,check_ Qkappa=57827.0d0 ! same properties everywhere in PREM crust if we decide to define only one layer in the crust - if(ONE_CRUST) then + if (ONE_CRUST) then vp = 5.8d0 vs = 3.36d0 rho = 2.72d0 diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_jp1d.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_jp1d.f90 index 2f5bd2b2c..cb4f196ff 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_jp1d.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_jp1d.f90 @@ -51,12 +51,12 @@ subroutine model_jp1d(myrank,x,rho,vp,vs,Qkappa,Qmu,idoubling, & ! check flags to make sure we correctly honor the discontinuities ! we use strict inequalities since r has been slighly changed in mesher - if(check_doubling_flag) then + if (check_doubling_flag) then !--- inner core ! - if(r >= 0.d0 .and. r < RICB) then - if(idoubling /= IFLAG_INNER_CORE_NORMAL .and. & + if (r >= 0.d0 .and. r < RICB) then + if (idoubling /= IFLAG_INNER_CORE_NORMAL .and. & idoubling /= IFLAG_MIDDLE_CENTRAL_CUBE .and. & idoubling /= IFLAG_BOTTOM_CENTRAL_CUBE .and. & idoubling /= IFLAG_TOP_CENTRAL_CUBE .and. & @@ -65,34 +65,34 @@ subroutine model_jp1d(myrank,x,rho,vp,vs,Qkappa,Qmu,idoubling, & ! !--- outer core ! - else if(r > RICB .and. r < RCMB) then - if(idoubling /= IFLAG_OUTER_CORE_NORMAL) & + else if (r > RICB .and. r < RCMB) then + if (idoubling /= IFLAG_OUTER_CORE_NORMAL) & call exit_MPI(myrank,'wrong doubling flag for outer core point') ! !--- D" at the base of the mantle ! - else if(r > RCMB .and. r < RTOPDDOUBLEPRIME) then - if(idoubling /= IFLAG_MANTLE_NORMAL) & + else if (r > RCMB .and. r < RTOPDDOUBLEPRIME) then + if (idoubling /= IFLAG_MANTLE_NORMAL) & call exit_MPI(myrank,'wrong doubling flag for D" point') ! !--- mantle: from top of D" to d670 ! - else if(r > RTOPDDOUBLEPRIME .and. r < R670) then - if(idoubling /= IFLAG_MANTLE_NORMAL) & + else if (r > RTOPDDOUBLEPRIME .and. r < R670) then + if (idoubling /= IFLAG_MANTLE_NORMAL) & call exit_MPI(myrank,'wrong doubling flag for top D" -> d670 point') ! !--- mantle: from d670 to d220 ! - else if(r > R670 .and. r < R220) then - if(idoubling /= IFLAG_670_220) & + else if (r > R670 .and. r < R220) then + if (idoubling /= IFLAG_670_220) & call exit_MPI(myrank,'wrong doubling flag for d670 -> d220 point') ! !--- mantle and crust: from d220 to MOHO and then to surface ! - else if(r > R220) then - if(idoubling /= IFLAG_220_80 .and. idoubling /= IFLAG_80_MOHO .and. idoubling /= IFLAG_CRUST) & + else if (r > R220) then + if (idoubling /= IFLAG_220_80 .and. idoubling /= IFLAG_80_MOHO .and. idoubling /= IFLAG_CRUST) & call exit_MPI(myrank,'wrong doubling flag for d220 -> Moho -> surface point') endif @@ -130,13 +130,13 @@ subroutine model_jp1d(myrank,x,rho,vp,vs,Qkappa,Qmu,idoubling, & ! !--- mantle: from top of D" to d670 ! - else if(r > RTOPDDOUBLEPRIME .and. r <= R771) then + else if (r > RTOPDDOUBLEPRIME .and. r <= R771) then rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x vp=-355.58324*x**4 + 1002.03178*x**3 - 1057.3873425*x**2 + 487.0891011*x - 68.520645 vs=-243.33862*x**4 + 668.06411*x**3 - 685.20113*x**2 + 308.04893*x - 43.737642 Qmu=312.0d0 Qkappa=57827.0d0 - else if(r > R771 .and. r <= R670) then + else if (r > R771 .and. r <= R670) then rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x vp=-174.468866*x**2 + 286.37769*x - 106.034798 vs=-81.0865*x*x + 129.67095*x - 45.268933 @@ -145,42 +145,42 @@ subroutine model_jp1d(myrank,x,rho,vp,vs,Qkappa,Qmu,idoubling, & ! !--- mantle: above d670 ! - else if(r > R670 .and. r <= 5871000.d0) then + else if (r > R670 .and. r <= 5871000.d0) then vp=-300.510146*x*x + 511.17372648*x - 206.265832 vs=-139.78275*x*x + 233.3097462*x - 91.0129372 rho=3.3d0 + (vs-4.4d0)*0.7d0 Qmu=143.0d0 Qkappa=57827.0d0 - else if(r > 5871000.d0 .and. r <= R400) then + else if (r > 5871000.d0 .and. r <= R400) then vp=-601.0202917*x*x + 1063.3823*x - 459.9388738 vs=-145.2465705*x*x + 243.2807524*x - 95.561877 rho=3.3d0 + (vs - 4.4d0)*0.7d0 Qmu=143.0d0 Qkappa=57827.0d0 - else if(r > R400 .and. r <= R220) then + else if (r > R400 .and. r <= R220) then vp=25.042512155*x*x - 68.8367583*x + 51.4120272 vs=15.540158021*x*x - 40.2087657*x + 28.9578929 rho=3.3d0 + (vs - 4.4d0)*0.7d0 Qmu=143.0d0 Qkappa=57827.0d0 - else if(r > R220 .and. r <= R80) then + else if (r > R220 .and. r <= R80) then vp=27.0989608 - 19.473338*x vs=13.920596 - 9.6309917*x rho=3.3d0 + (vs - 4.4d0)*0.7d0 Qmu=80.0d0 Qkappa=57827.0d0 - else if(r > R80 .and. r <= RMOHO) then + else if (r > R80 .and. r <= RMOHO) then vp=26.7663028 - 19.13645*x vs=13.4601434 - 9.164683*x rho=3.3d0 + (vs - 4.4d0)*0.7d0 Qmu=600.0d0 Qkappa=57827.0d0 - else if(r > RMOHO .and. r <= RMIDDLE_CRUST) then + else if (r > RMOHO .and. r <= RMIDDLE_CRUST) then rho=2.9d0 vp = 6.7d0 vs = 3.8d0 diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_prem.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_prem.f90 index 920d9f976..74fc93c7c 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_prem.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_prem.f90 @@ -51,14 +51,14 @@ subroutine prem_iso(myrank,x,rho,drhodr,vp,vs,Qkappa,Qmu,idoubling,CRUSTAL, & ! check flags to make sure we correctly honor the discontinuities ! we use strict inequalities since r has been slighly changed in mesher - if(check_doubling_flag) then + if (check_doubling_flag) then ! !--- inner core ! - if(r >= 0.d0 .and. r < RICB) then - if(idoubling /= IFLAG_INNER_CORE_NORMAL .and. & + if (r >= 0.d0 .and. r < RICB) then + if (idoubling /= IFLAG_INNER_CORE_NORMAL .and. & idoubling /= IFLAG_MIDDLE_CENTRAL_CUBE .and. & idoubling /= IFLAG_BOTTOM_CENTRAL_CUBE .and. & idoubling /= IFLAG_TOP_CENTRAL_CUBE .and. & @@ -67,34 +67,34 @@ subroutine prem_iso(myrank,x,rho,drhodr,vp,vs,Qkappa,Qmu,idoubling,CRUSTAL, & ! !--- outer core ! - else if(r > RICB .and. r < RCMB) then - if(idoubling /= IFLAG_OUTER_CORE_NORMAL) & + else if (r > RICB .and. r < RCMB) then + if (idoubling /= IFLAG_OUTER_CORE_NORMAL) & call exit_MPI(myrank,'wrong doubling flag for outer core point') ! !--- D" at the base of the mantle ! - else if(r > RCMB .and. r < RTOPDDOUBLEPRIME) then - if(idoubling /= IFLAG_MANTLE_NORMAL) & + else if (r > RCMB .and. r < RTOPDDOUBLEPRIME) then + if (idoubling /= IFLAG_MANTLE_NORMAL) & call exit_MPI(myrank,'wrong doubling flag for D" point') ! !--- mantle: from top of D" to d670 ! - else if(r > RTOPDDOUBLEPRIME .and. r < R670) then - if(idoubling /= IFLAG_MANTLE_NORMAL) & + else if (r > RTOPDDOUBLEPRIME .and. r < R670) then + if (idoubling /= IFLAG_MANTLE_NORMAL) & call exit_MPI(myrank,'wrong doubling flag for top D" -> d670 point') ! !--- mantle: from d670 to d220 ! - else if(r > R670 .and. r < R220) then - if(idoubling /= IFLAG_670_220) & + else if (r > R670 .and. r < R220) then + if (idoubling /= IFLAG_670_220) & call exit_MPI(myrank,'wrong doubling flag for d670 -> d220 point') ! !--- mantle and crust: from d220 to MOHO and then to surface ! - else if(r > R220) then - if(idoubling /= IFLAG_220_80 .and. idoubling /= IFLAG_80_MOHO .and. idoubling /= IFLAG_CRUST) & + else if (r > R220) then + if (idoubling /= IFLAG_220_80 .and. idoubling /= IFLAG_80_MOHO .and. idoubling /= IFLAG_CRUST) & call exit_MPI(myrank,'wrong doubling flag for d220 -> Moho -> surface point') endif @@ -104,7 +104,7 @@ subroutine prem_iso(myrank,x,rho,drhodr,vp,vs,Qkappa,Qmu,idoubling,CRUSTAL, & ! !--- inner core ! - if(r >= 0.d0 .and. r <= RICB) then + if (r >= 0.d0 .and. r <= RICB) then drhodr=-2.0d0*8.8381d0*x rho=13.0885d0-8.8381d0*x*x vp=11.2622d0-6.3640d0*x*x @@ -114,7 +114,7 @@ subroutine prem_iso(myrank,x,rho,drhodr,vp,vs,Qkappa,Qmu,idoubling,CRUSTAL, & ! !--- outer core ! - else if(r > RICB .and. r <= RCMB) then + else if (r > RICB .and. r <= RCMB) then drhodr=-1.2638d0-2.0d0*3.6426d0*x-3.0d0*5.5281d0*x*x rho=12.5815d0-1.2638d0*x-3.6426d0*x*x-5.5281d0*x*x*x vp=11.0487d0-4.0362d0*x+4.8023d0*x*x-13.5732d0*x*x*x @@ -124,7 +124,7 @@ subroutine prem_iso(myrank,x,rho,drhodr,vp,vs,Qkappa,Qmu,idoubling,CRUSTAL, & ! !--- D" at the base of the mantle ! - else if(r > RCMB .and. r <= RTOPDDOUBLEPRIME) then + else if (r > RCMB .and. r <= RTOPDDOUBLEPRIME) then drhodr=-6.4761d0+2.0d0*5.5283d0*x-3.0d0*3.0807d0*x*x rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x vp=15.3891d0-5.3181d0*x+5.5242d0*x*x-2.5514d0*x*x*x @@ -134,14 +134,14 @@ subroutine prem_iso(myrank,x,rho,drhodr,vp,vs,Qkappa,Qmu,idoubling,CRUSTAL, & ! !--- mantle: from top of D" to d670 ! - else if(r > RTOPDDOUBLEPRIME .and. r <= R771) then + else if (r > RTOPDDOUBLEPRIME .and. r <= R771) then drhodr=-6.4761d0+2.0d0*5.5283d0*x-3.0d0*3.0807d0*x*x rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x vp=24.9520d0-40.4673d0*x+51.4832d0*x*x-26.6419d0*x*x*x vs=11.1671d0-13.7818d0*x+17.4575d0*x*x-9.2777d0*x*x*x Qmu=312.0d0 Qkappa=57827.0d0 - else if(r > R771 .and. r <= R670) then + else if (r > R771 .and. r <= R670) then drhodr=-6.4761d0+2.0d0*5.5283d0*x-3.0d0*3.0807d0*x*x rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x vp=29.2766d0-23.6027d0*x+5.5242d0*x*x-2.5514d0*x*x*x @@ -151,28 +151,28 @@ subroutine prem_iso(myrank,x,rho,drhodr,vp,vs,Qkappa,Qmu,idoubling,CRUSTAL, & ! !--- mantle: above d670 ! - else if(r > R670 .and. r <= R600) then + else if (r > R670 .and. r <= R600) then drhodr=-1.4836d0 rho=5.3197d0-1.4836d0*x vp=19.0957d0-9.8672d0*x vs=9.9839d0-4.9324d0*x Qmu=143.0d0 Qkappa=57827.0d0 - else if(r > R600 .and. r <= R400) then + else if (r > R600 .and. r <= R400) then drhodr=-8.0298d0 rho=11.2494d0-8.0298d0*x vp=39.7027d0-32.6166d0*x vs=22.3512d0-18.5856d0*x Qmu=143.0d0 Qkappa=57827.0d0 - else if(r > R400 .and. r <= R220) then + else if (r > R400 .and. r <= R220) then drhodr=-3.8045d0 rho=7.1089d0-3.8045d0*x vp=20.3926d0-12.2569d0*x vs=8.9496d0-4.4597d0*x Qmu=143.0d0 Qkappa=57827.0d0 - else if(r > R220 .and. r <= R80) then + else if (r > R220 .and. r <= R80) then drhodr=0.6924d0 rho=2.6910d0+0.6924d0*x vp=4.1875d0+3.9382d0*x @@ -180,9 +180,9 @@ subroutine prem_iso(myrank,x,rho,drhodr,vp,vs,Qkappa,Qmu,idoubling,CRUSTAL, & Qmu=80.0d0 Qkappa=57827.0d0 else - if(CRUSTAL .and. .not. SUPPRESS_CRUSTAL_MESH) then + if (CRUSTAL .and. .not. SUPPRESS_CRUSTAL_MESH) then ! fill with PREM mantle and later add CRUST2.0 - if(r > R80) then + if (r > R80) then drhodr=0.6924d0 rho=2.6910d0+0.6924d0*x vp=4.1875d0+3.9382d0*x @@ -192,7 +192,7 @@ subroutine prem_iso(myrank,x,rho,drhodr,vp,vs,Qkappa,Qmu,idoubling,CRUSTAL, & endif else ! use PREM crust - if(r > R80 .and. r <= RMOHO) then + if (r > R80 .and. r <= RMOHO) then drhodr=0.6924d0 rho=2.6910d0+0.6924d0*x vp=4.1875d0+3.9382d0*x @@ -210,7 +210,7 @@ subroutine prem_iso(myrank,x,rho,drhodr,vp,vs,Qkappa,Qmu,idoubling,CRUSTAL, & Qmu=600.0d0 Qkappa=57827.0d0 - else if(r > RMOHO .and. r <= RMIDDLE_CRUST) then + else if (r > RMOHO .and. r <= RMIDDLE_CRUST) then drhodr=0.0d0 rho=2.9d0 vp=6.8d0 @@ -219,7 +219,7 @@ subroutine prem_iso(myrank,x,rho,drhodr,vp,vs,Qkappa,Qmu,idoubling,CRUSTAL, & Qkappa=57827.0d0 ! same properties everywhere in PREM crust if we decide to define only one layer in the crust - if(ONE_CRUST) then + if (ONE_CRUST) then drhodr=0.0d0 rho=2.6d0 vp=5.8d0 @@ -228,7 +228,7 @@ subroutine prem_iso(myrank,x,rho,drhodr,vp,vs,Qkappa,Qmu,idoubling,CRUSTAL, & Qkappa=57827.0d0 endif - else if(r > RMIDDLE_CRUST .and. r <= ROCEAN) then + else if (r > RMIDDLE_CRUST .and. r <= ROCEAN) then drhodr=0.0d0 rho=2.6d0 vp=5.8d0 @@ -236,7 +236,7 @@ subroutine prem_iso(myrank,x,rho,drhodr,vp,vs,Qkappa,Qmu,idoubling,CRUSTAL, & Qmu=600.0d0 Qkappa=57827.0d0 ! for density profile for gravity, we do not check that r <= R_EARTH - else if(r > ROCEAN) then + else if (r > ROCEAN) then drhodr=0.0d0 rho=2.6d0 vp=5.8d0 @@ -289,8 +289,8 @@ subroutine prem_aniso(myrank,x,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu, & ! !--- inner core ! - if(r >= 0.d0 .and. r < RICB) then - if(idoubling /= IFLAG_INNER_CORE_NORMAL .and. & + if (r >= 0.d0 .and. r < RICB) then + if (idoubling /= IFLAG_INNER_CORE_NORMAL .and. & idoubling /= IFLAG_MIDDLE_CENTRAL_CUBE .and. & idoubling /= IFLAG_BOTTOM_CENTRAL_CUBE .and. & idoubling /= IFLAG_TOP_CENTRAL_CUBE .and. & @@ -299,34 +299,34 @@ subroutine prem_aniso(myrank,x,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu, & ! !--- outer core ! - else if(r > RICB .and. r < RCMB) then - if(idoubling /= IFLAG_OUTER_CORE_NORMAL) & + else if (r > RICB .and. r < RCMB) then + if (idoubling /= IFLAG_OUTER_CORE_NORMAL) & call exit_MPI(myrank,'wrong doubling flag for outer core point') ! !--- D" at the base of the mantle ! - else if(r > RCMB .and. r < RTOPDDOUBLEPRIME) then - if(idoubling /= IFLAG_MANTLE_NORMAL) & + else if (r > RCMB .and. r < RTOPDDOUBLEPRIME) then + if (idoubling /= IFLAG_MANTLE_NORMAL) & call exit_MPI(myrank,'wrong doubling flag for D" point') ! !--- mantle: from top of D" to d670 ! - else if(r > RTOPDDOUBLEPRIME .and. r < R670) then - if(idoubling /= IFLAG_MANTLE_NORMAL) & + else if (r > RTOPDDOUBLEPRIME .and. r < R670) then + if (idoubling /= IFLAG_MANTLE_NORMAL) & call exit_MPI(myrank,'wrong doubling flag for top D" -> d670 point') ! !--- mantle: from d670 to d220 ! - else if(r > R670 .and. r < R220) then - if(idoubling /= IFLAG_670_220) & + else if (r > R670 .and. r < R220) then + if (idoubling /= IFLAG_670_220) & call exit_MPI(myrank,'wrong doubling flag for d670 -> d220 point') ! !--- mantle and crust: from d220 to MOHO and then to surface ! - else if(r > R220) then - if(idoubling /= IFLAG_220_80 .and. idoubling /= IFLAG_80_MOHO .and. idoubling /= IFLAG_CRUST) & + else if (r > R220) then + if (idoubling /= IFLAG_220_80 .and. idoubling /= IFLAG_80_MOHO .and. idoubling /= IFLAG_CRUST) & call exit_MPI(myrank,'wrong doubling flag for d220 -> Moho -> surface point') endif @@ -337,7 +337,7 @@ subroutine prem_aniso(myrank,x,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu, & ! !--- inner core ! - if(r >= 0.d0 .and. r <= RICB) then + if (r >= 0.d0 .and. r <= RICB) then rho=13.0885d0-8.8381d0*x*x vpv=11.2622d0-6.3640d0*x*x vsv=3.6678d0-4.4475d0*x*x @@ -348,7 +348,7 @@ subroutine prem_aniso(myrank,x,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu, & ! !--- outer core ! - else if(r > RICB .and. r <= RCMB) then + else if (r > RICB .and. r <= RCMB) then rho=12.5815d0-1.2638d0*x-3.6426d0*x*x-5.5281d0*x*x*x vpv=11.0487d0-4.0362d0*x+4.8023d0*x*x-13.5732d0*x*x*x vsv=0.0d0 @@ -359,7 +359,7 @@ subroutine prem_aniso(myrank,x,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu, & ! !--- D" at the base of the mantle ! - else if(r > RCMB .and. r <= RTOPDDOUBLEPRIME) then + else if (r > RCMB .and. r <= RTOPDDOUBLEPRIME) then rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x vpv=15.3891d0-5.3181d0*x+5.5242d0*x*x-2.5514d0*x*x*x vsv=6.9254d0+1.4672d0*x-2.0834d0*x*x+0.9783d0*x*x*x @@ -370,7 +370,7 @@ subroutine prem_aniso(myrank,x,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu, & ! !--- mantle: from top of D" to d670 ! - else if(r > RTOPDDOUBLEPRIME .and. r <= R771) then + else if (r > RTOPDDOUBLEPRIME .and. r <= R771) then rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x vpv=24.9520d0-40.4673d0*x+51.4832d0*x*x-26.6419d0*x*x*x vsv=11.1671d0-13.7818d0*x+17.4575d0*x*x-9.2777d0*x*x*x @@ -378,7 +378,7 @@ subroutine prem_aniso(myrank,x,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu, & vsh=vsv Qmu=312.0d0 Qkappa=57827.0d0 - else if(r > R771 .and. r <= R670) then + else if (r > R771 .and. r <= R670) then rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x vpv=29.2766d0-23.6027d0*x+5.5242d0*x*x-2.5514d0*x*x*x vsv=22.3459d0-17.2473d0*x-2.0834d0*x*x+0.9783d0*x*x*x @@ -389,7 +389,7 @@ subroutine prem_aniso(myrank,x,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu, & ! !--- mantle: above d670 ! - else if(r > R670 .and. r <= R600) then + else if (r > R670 .and. r <= R600) then rho=5.3197d0-1.4836d0*x vpv=19.0957d0-9.8672d0*x vsv=9.9839d0-4.9324d0*x @@ -397,7 +397,7 @@ subroutine prem_aniso(myrank,x,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu, & vsh=vsv Qmu=143.0d0 Qkappa=57827.0d0 - else if(r > R600 .and. r <= R400) then + else if (r > R600 .and. r <= R400) then rho=11.2494d0-8.0298d0*x vpv=39.7027d0-32.6166d0*x vsv=22.3512d0-18.5856d0*x @@ -405,7 +405,7 @@ subroutine prem_aniso(myrank,x,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu, & vsh=vsv Qmu=143.0d0 Qkappa=57827.0d0 - else if(r > R400 .and. r <= R220) then + else if (r > R400 .and. r <= R220) then rho=7.1089d0-3.8045d0*x vpv=20.3926d0-12.2569d0*x vsv=8.9496d0-4.4597d0*x @@ -413,7 +413,7 @@ subroutine prem_aniso(myrank,x,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu, & vsh=vsv Qmu=143.0d0 Qkappa=57827.0d0 - else if(r > R220 .and. r <= R80) then + else if (r > R220 .and. r <= R80) then ! anisotropy in PREM only above 220 km @@ -427,9 +427,9 @@ subroutine prem_aniso(myrank,x,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu, & Qkappa=57827.0d0 else - if(CRUSTAL) then + if (CRUSTAL) then ! fill with PREM mantle and later add CRUST2.0 - if(r > R80) then + if (r > R80) then rho=2.6910d0+0.6924d0*x vpv=0.8317d0+7.2180d0*x vph=3.5908d0+4.6172d0*x @@ -441,7 +441,7 @@ subroutine prem_aniso(myrank,x,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu, & endif else ! use PREM crust - if(r > R80 .and. r <= RMOHO) then + if (r > R80 .and. r <= RMOHO) then ! anisotropy in PREM only above 220 km @@ -456,7 +456,7 @@ subroutine prem_aniso(myrank,x,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu, & ! no anisotropy in the crust in PREM - else if(r > RMOHO .and. r <= RMIDDLE_CRUST) then + else if (r > RMOHO .and. r <= RMIDDLE_CRUST) then rho=2.9d0 vpv=6.8d0 vsv=3.9d0 @@ -466,7 +466,7 @@ subroutine prem_aniso(myrank,x,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu, & Qkappa=57827.0d0 ! same properties everywhere in PREM crust (only one layer in the crust) - if(ONE_CRUST) then + if (ONE_CRUST) then rho=2.6d0 vpv=5.8d0 vsv=3.2d0 @@ -476,7 +476,7 @@ subroutine prem_aniso(myrank,x,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu, & Qkappa=57827.0d0 endif - else if(r > RMIDDLE_CRUST .and. r <= ROCEAN) then + else if (r > RMIDDLE_CRUST .and. r <= ROCEAN) then rho=2.6d0 vpv=5.8d0 vsv=3.2d0 @@ -484,7 +484,7 @@ subroutine prem_aniso(myrank,x,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu, & vsh=vsv Qmu=600.0d0 Qkappa=57827.0d0 - else if(r > ROCEAN) then + else if (r > ROCEAN) then rho=2.6d0 vpv=5.8d0 vsv=3.2d0 @@ -529,7 +529,7 @@ subroutine prem_display_outer_core(myrank,x,rho,vp,vs,Qkappa,Qmu,idoubling) double precision scaleval - if(idoubling /= IFLAG_OUTER_CORE_NORMAL) call exit_MPI(myrank,'wrong doubling flag for outer core point') + if (idoubling /= IFLAG_OUTER_CORE_NORMAL) call exit_MPI(myrank,'wrong doubling flag for outer core point') ! !--- outer core @@ -569,36 +569,36 @@ subroutine prem_density(x,rho,ONE_CRUST,RICB,RCMB,RTOPDDOUBLEPRIME, & r = x * R_EARTH - if(r <= RICB) then + if (r <= RICB) then rho=13.0885d0-8.8381d0*x*x - else if(r > RICB .and. r <= RCMB) then + else if (r > RICB .and. r <= RCMB) then rho=12.5815d0-1.2638d0*x-3.6426d0*x*x-5.5281d0*x*x*x - else if(r > RCMB .and. r <= RTOPDDOUBLEPRIME) then + else if (r > RCMB .and. r <= RTOPDDOUBLEPRIME) then rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x - else if(r > RTOPDDOUBLEPRIME .and. r <= R771) then + else if (r > RTOPDDOUBLEPRIME .and. r <= R771) then rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x - else if(r > R771 .and. r <= R670) then + else if (r > R771 .and. r <= R670) then rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x - else if(r > R670 .and. r <= R600) then + else if (r > R670 .and. r <= R600) then rho=5.3197d0-1.4836d0*x - else if(r > R600 .and. r <= R400) then + else if (r > R600 .and. r <= R400) then rho=11.2494d0-8.0298d0*x - else if(r > R400 .and. r <= R220) then + else if (r > R400 .and. r <= R220) then rho=7.1089d0-3.8045d0*x - else if(r > R220 .and. r <= R80) then + else if (r > R220 .and. r <= R80) then rho=2.6910d0+0.6924d0*x else - if(r > R80 .and. r <= RMOHO) then + if (r > R80 .and. r <= RMOHO) then rho=2.6910d0+0.6924d0*x - else if(r > RMOHO .and. r <= RMIDDLE_CRUST) then - if(ONE_CRUST) then + else if (r > RMOHO .and. r <= RMIDDLE_CRUST) then + if (ONE_CRUST) then rho=2.6d0 else rho=2.9d0 endif - else if(r > RMIDDLE_CRUST .and. r <= ROCEAN) then + else if (r > RMIDDLE_CRUST .and. r <= ROCEAN) then rho=2.6d0 - else if(r > ROCEAN) then + else if (r > ROCEAN) then rho=2.6d0 endif endif diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_ref.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_ref.f90 index cb452d864..e79da8360 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_ref.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_ref.f90 @@ -80,16 +80,16 @@ subroutine model_ref(x,rho,vpv,vph,vsv,vsh,eta,Qkappa,Qmu,iregion_code,CRUSTAL,M enddo ! make sure we stay in the right region - if(iregion_code == IREGION_INNER_CORE .and. i > 180) i = 180 + if (iregion_code == IREGION_INNER_CORE .and. i > 180) i = 180 - if(iregion_code == IREGION_OUTER_CORE .and. i < 182) i = 182 - if(iregion_code == IREGION_OUTER_CORE .and. i > 358) i = 358 + if (iregion_code == IREGION_OUTER_CORE .and. i < 182) i = 182 + if (iregion_code == IREGION_OUTER_CORE .and. i > 358) i = 358 - if(iregion_code == IREGION_CRUST_MANTLE .and. i < 360) i = 360 - if(CRUSTAL .and. i > 717) i = 717 + if (iregion_code == IREGION_CRUST_MANTLE .and. i < 360) i = 360 + if (CRUSTAL .and. i > 717) i = 717 - if(i == 1) then + if (i == 1) then rho = Mref_V%density_ref(i) vpv = Mref_V%vpv_ref(i) vph = Mref_V%vph_ref(i) @@ -116,7 +116,7 @@ subroutine model_ref(x,rho,vpv,vph,vsv,vsh,eta,Qkappa,Qmu,iregion_code,CRUSTAL,M ! make sure Vs is zero in the outer core even if roundoff errors on depth ! also set fictitious attenuation to a very high value (attenuation is not used in the fluid) - if(iregion_code == IREGION_OUTER_CORE) then + if (iregion_code == IREGION_OUTER_CORE) then vsv = 0.d0 vsh = 0.d0 Qkappa = 3000.d0 diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_sea1d.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_sea1d.f90 index ea4ca9e49..5cfaad1f9 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_sea1d.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/model_sea1d.f90 @@ -74,14 +74,14 @@ subroutine model_sea1d(x,rho,vp,vs,Qkappa,Qmu,iregion_code,SEA1DM_V) enddo ! make sure we stay in the right region - if(iregion_code == IREGION_INNER_CORE .and. i > 13) i = 13 + if (iregion_code == IREGION_INNER_CORE .and. i > 13) i = 13 - if(iregion_code == IREGION_OUTER_CORE .and. i < 15) i = 15 - if(iregion_code == IREGION_OUTER_CORE .and. i > 37) i = 37 + if (iregion_code == IREGION_OUTER_CORE .and. i < 15) i = 15 + if (iregion_code == IREGION_OUTER_CORE .and. i > 37) i = 37 - if(iregion_code == IREGION_CRUST_MANTLE .and. i < 39) i = 39 + if (iregion_code == IREGION_CRUST_MANTLE .and. i < 39) i = 39 - if(i == 1) then + if (i == 1) then rho = SEA1DM_V%density_sea1d(i) vp = SEA1DM_V%vp_sea1d(i) vs = SEA1DM_V%vs_sea1d(i) @@ -102,7 +102,7 @@ subroutine model_sea1d(x,rho,vp,vs,Qkappa,Qmu,iregion_code,SEA1DM_V) ! make sure Vs is zero in the outer core even if roundoff errors on depth ! also set fictitious attenuation to a very high value (attenuation is not used in the fluid) - if(iregion_code == IREGION_OUTER_CORE) then + if (iregion_code == IREGION_OUTER_CORE) then vs = 0.d0 Qkappa = 3000.d0 Qmu = 3000.d0 @@ -1130,7 +1130,7 @@ subroutine define_model_sea1d(USE_EXTERNAL_CRUSTAL_MODEL,SEA1DM_V) SEA1DM_V%Qmu_sea1d(163)= 300.0000000000000 ! strip the crust and replace it by mantle - if(USE_EXTERNAL_CRUSTAL_MODEL) then + if (USE_EXTERNAL_CRUSTAL_MODEL) then do i=NR_SEA1D-12,NR_SEA1D SEA1DM_V%density_sea1d(i) = SEA1DM_V%density_sea1d(NR_SEA1D-13) SEA1DM_V%vp_sea1d(i) = SEA1DM_V%vp_sea1d(NR_SEA1D-13) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/moho_stretching.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/moho_stretching.f90 index 500c784da..ae1edd9ec 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/moho_stretching.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/moho_stretching.f90 @@ -76,14 +76,14 @@ subroutine moho_stretching(myrank,xelm,yelm,zelm,RMOHO,R220) elevation = -0.25d0*elevation/R_EARTH_KM gamma = 0.0d0 - if(r >= RMOHO/R_EARTH) then + if (r >= RMOHO/R_EARTH) then ! stretching above the Moho gamma = (1.0d0 - r) / (1.0d0 - RMOHO/R_EARTH) - else if(r>= R220/R_EARTH .and. r< RMOHO/R_EARTH) then + else if (r>= R220/R_EARTH .and. r< RMOHO/R_EARTH) then ! stretching between R220 and RMOHO gamma = (r - R220/R_EARTH) / (RMOHO/R_EARTH - R220/R_EARTH) endif - if(gamma < -0.0001 .or. gamma > 1.0001) call exit_MPI(myrank,'incorrect value of gamma for Moho topography') + if (gamma < -0.0001 .or. gamma > 1.0001) call exit_MPI(myrank,'incorrect value of gamma for Moho topography') xelm(ia) = xelm(ia)*(ONE + gamma * elevation / r) yelm(ia) = yelm(ia)*(ONE + gamma * elevation / r) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/netlib_specfun_erf.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/netlib_specfun_erf.f90 index c354a971f..43989785a 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/netlib_specfun_erf.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/netlib_specfun_erf.f90 @@ -13,8 +13,8 @@ subroutine calerf(ARG,RESULT,JINT) !------------------------------------------------------------------ ! ! This packet evaluates erf(x) for a real argument x. -! It contains one FUNCTION type subprogram: ERF, -! and one SUBROUTINE type subprogram, CALERF. The calling +! It contains one function type subprogram: ERF, +! and one subroutine type subprogram, CALERF. The calling ! statements for the primary entries are: ! ! Y = ERF(X) @@ -28,7 +28,7 @@ subroutine calerf(ARG,RESULT,JINT) ! ! where the parameter usage is as follows ! -! Function Parameters for CALERF +! function Parameters for CALERF ! call ARG Result JINT ! ! ERF(ARG) ANY REAL ARGUMENT ERF(ARG) 0 diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/read_compute_parameters.F90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/read_compute_parameters.F90 index 08e6cf4c7..d454bf8c6 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/read_compute_parameters.F90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/read_compute_parameters.F90 @@ -148,40 +148,40 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD call open_parameter_file call read_value_integer(SIMULATION_TYPE, 'solver.SIMULATION_TYPE') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_logical(SAVE_FORWARD, 'solver.SAVE_FORWARD') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_integer(NCHUNKS, 'mesher.NCHUNKS') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' - if(NCHUNKS /= 1 .and. NCHUNKS /= 2 .and. NCHUNKS /= 3 .and. NCHUNKS /= 6) & + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (NCHUNKS /= 1 .and. NCHUNKS /= 2 .and. NCHUNKS /= 3 .and. NCHUNKS /= 6) & stop 'NCHUNKS must be either 1, 2, 3 or 6' call read_value_double_precision(ANGULAR_WIDTH_XI_IN_DEGREES, 'mesher.ANGULAR_WIDTH_XI_IN_DEGREES') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_double_precision(ANGULAR_WIDTH_ETA_IN_DEGREES, 'mesher.ANGULAR_WIDTH_ETA_IN_DEGREES') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_double_precision(CENTER_LATITUDE_IN_DEGREES, 'mesher.CENTER_LATITUDE_IN_DEGREES') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_double_precision(CENTER_LONGITUDE_IN_DEGREES, 'mesher.CENTER_LONGITUDE_IN_DEGREES') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_double_precision(GAMMA_ROTATION_AZIMUTH, 'mesher.GAMMA_ROTATION_AZIMUTH') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' !! DK DK this version of the mesher for the GPU + MPI solver is limited to one chunk for now - if(NCHUNKS > 1) stop 'this version of the mesher for the GPU + MPI solver is limited to one chunk for now' + if (NCHUNKS > 1) stop 'this version of the mesher for the GPU + MPI solver is limited to one chunk for now' ! this MUST be 90 degrees for two chunks or more to match geometrically - if(NCHUNKS > 1 .and. abs(ANGULAR_WIDTH_XI_IN_DEGREES - 90.d0) > 0.00000001d0) & + if (NCHUNKS > 1 .and. abs(ANGULAR_WIDTH_XI_IN_DEGREES - 90.d0) > 0.00000001d0) & stop 'ANGULAR_WIDTH_XI_IN_DEGREES must be 90 for more than one chunk' ! this can be any value in the case of two chunks - if(NCHUNKS > 2 .and. abs(ANGULAR_WIDTH_ETA_IN_DEGREES - 90.d0) > 0.00000001d0) & + if (NCHUNKS > 2 .and. abs(ANGULAR_WIDTH_ETA_IN_DEGREES - 90.d0) > 0.00000001d0) & stop 'ANGULAR_WIDTH_ETA_IN_DEGREES must be 90 for more than two chunks' ! include central cube or not ! use regular cubed sphere instead of cube for large distances - if(NCHUNKS == 6) then + if (NCHUNKS == 6) then INCLUDE_CENTRAL_CUBE = .true. INFLATE_CENTRAL_CUBE = .false. else @@ -191,15 +191,15 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD ! number of elements at the surface along the two sides of the first chunk call read_value_integer(NEX_XI_read, 'mesher.NEX_XI') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_integer(NEX_ETA_read, 'mesher.NEX_ETA') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_integer(NPROC_XI_read, 'mesher.NPROC_XI') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_integer(NPROC_ETA_read, 'mesher.NPROC_ETA') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' - if(.not. EMULATE_ONLY) then + if (.not. EMULATE_ONLY) then NEX_XI = NEX_XI_read NEX_ETA = NEX_ETA_read NPROC_XI = NPROC_XI_read @@ -212,7 +212,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD ! define the velocity model call read_value_string(MODEL, 'model.name') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' ! use PREM as the 1D reference model by default REFERENCE_1D_MODEL = REFERENCE_MODEL_PREM @@ -236,7 +236,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD ! default is no 3D model THREE_D_MODEL = 0 - if(MODEL == '1D_isotropic_prem') then + if (MODEL == '1D_isotropic_prem') then TRANSVERSE_ISOTROPY = .false. ISOTROPIC_3D_MANTLE = .false. ANISOTROPIC_3D_MANTLE = .false. @@ -245,7 +245,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD ATTENUATION_3D = .false. HONOR_1D_SPHERICAL_MOHO = .true. - else if(MODEL == '1D_transversely_isotropic_prem') then + else if (MODEL == '1D_transversely_isotropic_prem') then TRANSVERSE_ISOTROPY = .true. ISOTROPIC_3D_MANTLE = .false. ANISOTROPIC_3D_MANTLE = .false. @@ -254,18 +254,18 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD ATTENUATION_3D = .false. HONOR_1D_SPHERICAL_MOHO = .true. - else if(MODEL == '1D_iasp91' .or. MODEL == '1D_1066a' .or. & + else if (MODEL == '1D_iasp91' .or. MODEL == '1D_1066a' .or. & MODEL == '1D_ak135' .or. MODEL == '1D_jp3d' .or. & MODEL == '1D_sea99') then - if(MODEL == '1D_iasp91') then + if (MODEL == '1D_iasp91') then REFERENCE_1D_MODEL = REFERENCE_MODEL_IASP91 - else if(MODEL == '1D_1066a') then + else if (MODEL == '1D_1066a') then REFERENCE_1D_MODEL = REFERENCE_MODEL_1066A - else if(MODEL == '1D_ak135') then + else if (MODEL == '1D_ak135') then REFERENCE_1D_MODEL = REFERENCE_MODEL_AK135 - else if(MODEL == '1D_jp3d') then + else if (MODEL == '1D_jp3d') then REFERENCE_1D_MODEL = REFERENCE_MODEL_JP1D - else if(MODEL == '1D_sea99') then + else if (MODEL == '1D_sea99') then REFERENCE_1D_MODEL = REFERENCE_MODEL_SEA1D else stop 'reference 1D Earth model unknown' @@ -278,7 +278,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD ATTENUATION_3D = .false. HONOR_1D_SPHERICAL_MOHO = .true. - else if(MODEL == '1D_ref') then + else if (MODEL == '1D_ref') then TRANSVERSE_ISOTROPY = .true. ISOTROPIC_3D_MANTLE = .false. ANISOTROPIC_3D_MANTLE = .false. @@ -288,7 +288,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD HONOR_1D_SPHERICAL_MOHO = .true. REFERENCE_1D_MODEL = REFERENCE_MODEL_REF - else if(MODEL == '1D_ref_iso') then + else if (MODEL == '1D_ref_iso') then TRANSVERSE_ISOTROPY = .false. ISOTROPIC_3D_MANTLE = .false. ANISOTROPIC_3D_MANTLE = .false. @@ -298,7 +298,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD HONOR_1D_SPHERICAL_MOHO = .true. REFERENCE_1D_MODEL = REFERENCE_MODEL_REF - else if(MODEL == '1D_isotropic_prem_onecrust') then + else if (MODEL == '1D_isotropic_prem_onecrust') then TRANSVERSE_ISOTROPY = .false. ISOTROPIC_3D_MANTLE = .false. ANISOTROPIC_3D_MANTLE = .false. @@ -308,7 +308,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD HONOR_1D_SPHERICAL_MOHO = .true. ONE_CRUST = .true. - else if(MODEL == '1D_transversely_isotropic_prem_onecrust') then + else if (MODEL == '1D_transversely_isotropic_prem_onecrust') then TRANSVERSE_ISOTROPY = .true. ISOTROPIC_3D_MANTLE = .false. ANISOTROPIC_3D_MANTLE = .false. @@ -318,12 +318,12 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD HONOR_1D_SPHERICAL_MOHO = .true. ONE_CRUST = .true. - else if(MODEL == '1D_iasp91_onecrust' .or. MODEL == '1D_1066a_onecrust' .or. MODEL == '1D_ak135_onecrust') then - if(MODEL == '1D_iasp91_onecrust') then + else if (MODEL == '1D_iasp91_onecrust' .or. MODEL == '1D_1066a_onecrust' .or. MODEL == '1D_ak135_onecrust') then + if (MODEL == '1D_iasp91_onecrust') then REFERENCE_1D_MODEL = REFERENCE_MODEL_IASP91 - else if(MODEL == '1D_1066a_onecrust') then + else if (MODEL == '1D_1066a_onecrust') then REFERENCE_1D_MODEL = REFERENCE_MODEL_1066A - else if(MODEL == '1D_ak135_onecrust') then + else if (MODEL == '1D_ak135_onecrust') then REFERENCE_1D_MODEL = REFERENCE_MODEL_AK135 else stop 'reference 1D Earth model unknown' @@ -337,7 +337,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD HONOR_1D_SPHERICAL_MOHO = .true. ONE_CRUST = .true. - else if(MODEL == 'transversely_isotropic_prem_plus_3D_crust_2.0') then + else if (MODEL == 'transversely_isotropic_prem_plus_3D_crust_2.0') then TRANSVERSE_ISOTROPY = .true. ISOTROPIC_3D_MANTLE = .false. ANISOTROPIC_3D_MANTLE = .false. @@ -347,7 +347,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD ONE_CRUST = .true. CASE_3D = .true. - else if(MODEL == 's20rts') then + else if (MODEL == 's20rts') then TRANSVERSE_ISOTROPY = .true. ISOTROPIC_3D_MANTLE = .true. ANISOTROPIC_3D_MANTLE = .false. @@ -359,7 +359,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD REFERENCE_1D_MODEL = REFERENCE_MODEL_PREM THREE_D_MODEL = THREE_D_MODEL_S20RTS - else if(MODEL == 'sea99_jp3d1994') then + else if (MODEL == 'sea99_jp3d1994') then TRANSVERSE_ISOTROPY = .false. ISOTROPIC_3D_MANTLE = .true. ANISOTROPIC_3D_MANTLE = .false. @@ -371,7 +371,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD REFERENCE_1D_MODEL = REFERENCE_MODEL_SEA1D THREE_D_MODEL = THREE_D_MODEL_SEA99_JP3D - else if(MODEL == 'sea99') then + else if (MODEL == 'sea99') then TRANSVERSE_ISOTROPY = .false. ISOTROPIC_3D_MANTLE = .true. ANISOTROPIC_3D_MANTLE = .false. @@ -384,7 +384,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD THREE_D_MODEL = THREE_D_MODEL_SEA99 - else if(MODEL == 'jp3d1994') then + else if (MODEL == 'jp3d1994') then TRANSVERSE_ISOTROPY = .false. ISOTROPIC_3D_MANTLE = .true. ANISOTROPIC_3D_MANTLE = .false. @@ -396,7 +396,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD REFERENCE_1D_MODEL = REFERENCE_MODEL_JP1D THREE_D_MODEL = THREE_D_MODEL_JP3D - else if(MODEL == 's362ani') then + else if (MODEL == 's362ani') then TRANSVERSE_ISOTROPY = .true. ISOTROPIC_3D_MANTLE = .true. ANISOTROPIC_3D_MANTLE = .false. @@ -408,7 +408,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD REFERENCE_1D_MODEL = REFERENCE_MODEL_REF THREE_D_MODEL = THREE_D_MODEL_S362ANI - else if(MODEL == 's362iso') then + else if (MODEL == 's362iso') then TRANSVERSE_ISOTROPY = .false. ISOTROPIC_3D_MANTLE = .true. ANISOTROPIC_3D_MANTLE = .false. @@ -420,7 +420,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD REFERENCE_1D_MODEL = REFERENCE_MODEL_REF THREE_D_MODEL = THREE_D_MODEL_S362ANI - else if(MODEL == 's362wmani') then + else if (MODEL == 's362wmani') then TRANSVERSE_ISOTROPY = .true. ISOTROPIC_3D_MANTLE = .true. ANISOTROPIC_3D_MANTLE = .false. @@ -432,7 +432,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD REFERENCE_1D_MODEL = REFERENCE_MODEL_REF THREE_D_MODEL = THREE_D_MODEL_S362WMANI - else if(MODEL == 's362ani_prem') then + else if (MODEL == 's362ani_prem') then TRANSVERSE_ISOTROPY = .true. ISOTROPIC_3D_MANTLE = .true. ANISOTROPIC_3D_MANTLE = .false. @@ -444,7 +444,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD REFERENCE_1D_MODEL = REFERENCE_MODEL_PREM THREE_D_MODEL = THREE_D_MODEL_S362ANI_PREM - else if(MODEL == 's29ea') then + else if (MODEL == 's29ea') then TRANSVERSE_ISOTROPY = .true. ISOTROPIC_3D_MANTLE = .true. ANISOTROPIC_3D_MANTLE = .false. @@ -456,7 +456,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD REFERENCE_1D_MODEL = REFERENCE_MODEL_REF THREE_D_MODEL = THREE_D_MODEL_S29EA - else if(MODEL == '3D_attenuation') then + else if (MODEL == '3D_attenuation') then TRANSVERSE_ISOTROPY = .false. ISOTROPIC_3D_MANTLE = .false. ANISOTROPIC_3D_MANTLE = .false. @@ -466,7 +466,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD ONE_CRUST = .true. CASE_3D = .true. - else if(MODEL == '3D_anisotropic') then + else if (MODEL == '3D_anisotropic') then TRANSVERSE_ISOTROPY = .true. ISOTROPIC_3D_MANTLE = .false. ANISOTROPIC_3D_MANTLE = .true. @@ -494,7 +494,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD endif ! element width = 0.5625000 degrees = 62.54715 km - if(NEX_MAX*multiplication_factor <= 160) then + if (NEX_MAX*multiplication_factor <= 160) then DT = 0.252d0 MIN_ATTENUATION_PERIOD = 30 @@ -514,7 +514,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD R_CENTRAL_CUBE = 950000.d0 ! element width = 0.3515625 degrees = 39.09196 km - else if(NEX_MAX*multiplication_factor <= 256) then + else if (NEX_MAX*multiplication_factor <= 256) then DT = 0.225d0 MIN_ATTENUATION_PERIOD = 20 @@ -534,7 +534,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD R_CENTRAL_CUBE = 965000.d0 ! element width = 0.2812500 degrees = 31.27357 km - else if(NEX_MAX*multiplication_factor <= 320) then + else if (NEX_MAX*multiplication_factor <= 320) then DT = 0.16d0 MIN_ATTENUATION_PERIOD = 15 @@ -554,7 +554,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD R_CENTRAL_CUBE = 940000.d0 ! element width = 0.1875000 degrees = 20.84905 km - else if(NEX_MAX*multiplication_factor <= 480) then + else if (NEX_MAX*multiplication_factor <= 480) then DT = 0.11d0 MIN_ATTENUATION_PERIOD = 10 @@ -574,7 +574,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD R_CENTRAL_CUBE = 988000.d0 ! element width = 0.1757812 degrees = 19.54598 km - else if(NEX_MAX*multiplication_factor <= 512) then + else if (NEX_MAX*multiplication_factor <= 512) then DT = 0.1125d0 MIN_ATTENUATION_PERIOD = 9 @@ -594,7 +594,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD R_CENTRAL_CUBE = 1010000.d0 ! element width = 0.1406250 degrees = 15.63679 km - else if(NEX_MAX*multiplication_factor <= 640) then + else if (NEX_MAX*multiplication_factor <= 640) then DT = 0.09d0 MIN_ATTENUATION_PERIOD = 8 @@ -614,7 +614,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD R_CENTRAL_CUBE = 1020000.d0 ! element width = 0.1041667 degrees = 11.58280 km - else if(NEX_MAX*multiplication_factor <= 864) then + else if (NEX_MAX*multiplication_factor <= 864) then DT = 0.0667d0 MIN_ATTENUATION_PERIOD = 6 @@ -634,7 +634,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD R_CENTRAL_CUBE = 990000.d0 ! element width = 7.8125000E-02 degrees = 8.687103 km - else if(NEX_MAX*multiplication_factor <= 1152) then + else if (NEX_MAX*multiplication_factor <= 1152) then DT = 0.05d0 MIN_ATTENUATION_PERIOD = 4 @@ -654,7 +654,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD R_CENTRAL_CUBE = 985000.d0 ! element width = 7.2115384E-02 degrees = 8.018865 km - else if(NEX_MAX*multiplication_factor <= 1248) then + else if (NEX_MAX*multiplication_factor <= 1248) then DT = 0.0462d0 MIN_ATTENUATION_PERIOD = 4 @@ -708,20 +708,20 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD if (.not. ONE_CRUST) then ! case 1D + two crustal layers if (NER_CRUST<2) NER_CRUST=2 - if(NEX_MAX*multiplication_factor <= 160) then + if (NEX_MAX*multiplication_factor <= 160) then DT = 0.20d0 - else if(NEX_MAX*multiplication_factor <= 256) then + else if (NEX_MAX*multiplication_factor <= 256) then DT = 0.20d0 endif endif else ! case 3D if (NER_CRUST<2) NER_CRUST=2 - if(NEX_MAX*multiplication_factor <= 160) then + if (NEX_MAX*multiplication_factor <= 160) then DT = 0.15d0 - else if(NEX_MAX*multiplication_factor <= 256) then + else if (NEX_MAX*multiplication_factor <= 256) then DT = 0.17d0 - else if(NEX_MAX*multiplication_factor <= 320) then + else if (NEX_MAX*multiplication_factor <= 320) then DT = 0.155d0 endif endif @@ -731,12 +731,12 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD endif - if( .not. ATTENUATION_RANGE_PREDEFINED ) then + if ( .not. ATTENUATION_RANGE_PREDEFINED ) then call auto_attenuation_periods(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, & MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD) endif - if(ANGULAR_WIDTH_XI_IN_DEGREES < 90.0d0 .or. & + if (ANGULAR_WIDTH_XI_IN_DEGREES < 90.0d0 .or. & ANGULAR_WIDTH_ETA_IN_DEGREES < 90.0d0 .or. & NEX_MAX > 1248) then @@ -798,26 +798,26 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD !!!!!!!! DT = DT * (1.d0 - 0.05d0) call read_value_logical(OCEANS, 'model.OCEANS') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_logical(ELLIPTICITY, 'model.ELLIPTICITY') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_logical(TOPOGRAPHY, 'model.TOPOGRAPHY') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_logical(GRAVITY, 'model.GRAVITY') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_logical(ROTATION, 'model.ROTATION') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_logical(ATTENUATION, 'model.ATTENUATION') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_logical(ABSORBING_CONDITIONS, 'solver.ABSORBING_CONDITIONS') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' - if(ABSORBING_CONDITIONS .and. NCHUNKS == 6) stop 'cannot have absorbing conditions in the full Earth' + if (ABSORBING_CONDITIONS .and. NCHUNKS == 6) stop 'cannot have absorbing conditions in the full Earth' - if(ABSORBING_CONDITIONS .and. NCHUNKS == 3) stop 'absorbing conditions not supported for three chunks yet' + if (ABSORBING_CONDITIONS .and. NCHUNKS == 3) stop 'absorbing conditions not supported for three chunks yet' - if(ATTENUATION_3D .and. .not. ATTENUATION) stop 'need ATTENUATION to use ATTENUATION_3D' + if (ATTENUATION_3D .and. .not. ATTENUATION) stop 'need ATTENUATION to use ATTENUATION_3D' ! radii in PREM or IASP91 ! and normalized density at fluid-solid interface on fluid size for coupling @@ -841,7 +841,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD ! value common to all models RHO_OCEANS = 1020.0 / RHOAV - if(REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) then + if (REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) then ! IASP91 ROCEAN = 6371000.d0 @@ -863,7 +863,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD RHO_TOP_OC = 9900.2379 / RHOAV RHO_BOTTOM_OC = 12168.6383 / RHOAV - else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135) then + else if (REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135) then ! our implementation of AK135 has not been checked carefully yet ! therefore let us doublecheck it carefully one day @@ -889,7 +889,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD RHO_TOP_OC = 9914.5000 / RHOAV RHO_BOTTOM_OC = 12139.1000 / RHOAV - else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then + else if (REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then ! values below corrected by Ying Zhou @@ -916,7 +916,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD RHO_TOP_OC = 9917.4500 / RHOAV RHO_BOTTOM_OC = 12160.6500 / RHOAV - else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then + else if (REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then ! REF ROCEAN = 6368000.d0 @@ -935,7 +935,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD RHO_TOP_OC = 9903.48 / RHOAV RHO_BOTTOM_OC = 12166.35 / RHOAV - else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_JP1D) then + else if (REFERENCE_1D_MODEL == REFERENCE_MODEL_JP1D) then ! values below corrected by Min Chen @@ -955,7 +955,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD RHO_TOP_OC = 9900.2379 / RHOAV RHO_BOTTOM_OC = 12168.6383 / RHOAV - else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) then + else if (REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) then ! SEA1D without the 2 km of mud layer or the 3km water layer ROCEAN = 6371000.d0 @@ -999,53 +999,53 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD ! honor the PREM Moho or define a fictitious Moho in order to have even radial sampling ! from the d220 to the Earth surface - if(HONOR_1D_SPHERICAL_MOHO) then + if (HONOR_1D_SPHERICAL_MOHO) then RMOHO_FICTITIOUS_IN_MESHER = RMOHO else RMOHO_FICTITIOUS_IN_MESHER = (R80 + R_EARTH) / 2 endif call read_value_double_precision(RECORD_LENGTH_IN_MINUTES, 'solver.RECORD_LENGTH_IN_MINUTES') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' ! compute total number of time steps, rounded to next multiple of 100 NSTEP = 100 * (int(RECORD_LENGTH_IN_MINUTES * 60.d0 / (100.d0*DT)) + 1) call read_value_logical(MOVIE_SURFACE, 'solver.MOVIE_SURFACE') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_logical(MOVIE_VOLUME, 'solver.MOVIE_VOLUME') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_logical(MOVIE_COARSE,'solver.MOVIE_COARSE') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_integer(NTSTEP_BETWEEN_FRAMES, 'solver.NTSTEP_BETWEEN_FRAMES') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_double_precision(HDUR_MOVIE, 'solver.HDUR_MOVIE') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' ! computes a default hdur_movie that creates nice looking movies. ! Sets HDUR_MOVIE as the minimum period the mesh can resolve - if(HDUR_MOVIE <= TINYVAL) & + if (HDUR_MOVIE <= TINYVAL) & HDUR_MOVIE = 1.2d0*max(240.d0/NEX_XI*18.d0*ANGULAR_WIDTH_XI_IN_DEGREES/90.d0, & 240.d0/NEX_ETA*18.d0*ANGULAR_WIDTH_ETA_IN_DEGREES/90.d0) call read_value_integer(MOVIE_VOLUME_TYPE, 'solver.MOVIE_VOLUME_TYPE') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_double_precision(MOVIE_TOP_KM, 'solver.MOVIE_TOP_KM') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_double_precision(MOVIE_BOTTOM_KM, 'solver.MOVIE_BOTTOM_KM') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_double_precision(MOVIE_WEST_DEG, 'solver.MOVIE_WEST_DEG') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_double_precision(MOVIE_EAST_DEG, 'solver.MOVIE_EAST_DEG') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_double_precision(MOVIE_NORTH_DEG, 'solver.MOVIE_NORTH_DEG') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_double_precision(MOVIE_SOUTH_DEG, 'solver.MOVIE_SOUTH_DEG') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_integer(MOVIE_START, 'solver.MOVIE_START') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_integer(MOVIE_STOP, 'solver.MOVIE_STOP') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' MOVIE_TOP = (R_EARTH_KM-MOVIE_TOP_KM)/R_EARTH_KM MOVIE_BOTTOM = (R_EARTH_KM-MOVIE_BOTTOM_KM)/R_EARTH_KM MOVIE_EAST = MOVIE_EAST_DEG * DEGREES_TO_RADIANS @@ -1054,40 +1054,40 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD MOVIE_SOUTH = (90.0d0 - MOVIE_SOUTH_DEG) * DEGREES_TO_RADIANS call read_value_logical(SAVE_MESH_FILES, 'mesher.SAVE_MESH_FILES') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_integer(NUMBER_OF_RUNS, 'solver.NUMBER_OF_RUNS') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_integer(NUMBER_OF_THIS_RUN, 'solver.NUMBER_OF_THIS_RUN') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_string(LOCAL_PATH, 'LOCAL_PATH') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_integer(NTSTEP_BETWEEN_OUTPUT_INFO, 'solver.NTSTEP_BETWEEN_OUTPUT_INFO') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_integer(NTSTEP_BETWEEN_OUTPUT_SEISMOS, 'solver.NTSTEP_BETWEEN_OUTPUT_SEISMOS') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_integer(NTSTEP_BETWEEN_READ_ADJSRC, 'solver.NTSTEP_BETWEEN_READ_ADJSRC') - if(err_occurred() /= 0) return + if (err_occurred() /= 0) return call read_value_logical(OUTPUT_SEISMOS_ASCII_TEXT, 'solver.OUTPUT_SEISMOS_ASCII_TEXT') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_logical(OUTPUT_SEISMOS_SAC_ALPHANUM, 'solver.OUTPUT_SEISMOS_SAC_ALPHANUM') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_logical(OUTPUT_SEISMOS_SAC_BINARY, 'solver.OUTPUT_SEISMOS_SAC_BINARY') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_logical(ROTATE_SEISMOGRAMS_RT, 'solver.ROTATE_SEISMOGRAMS_RT') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_logical(WRITE_SEISMOGRAMS_BY_MASTER, 'solver.WRITE_SEISMOGRAMS_BY_MASTER') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_logical(SAVE_ALL_SEISMOS_IN_ONE_FILE, 'solver.SAVE_ALL_SEISMOS_IN_ONE_FILE') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_logical(USE_BINARY_FOR_LARGE_FILE, 'solver.USE_BINARY_FOR_LARGE_FILE') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_logical(RECEIVERS_CAN_BE_BURIED, 'solver.RECEIVERS_CAN_BE_BURIED') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' call read_value_logical(PRINT_SOURCE_TIME_FUNCTION, 'solver.PRINT_SOURCE_TIME_FUNCTION') - if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file' + if (err_occurred() /= 0) stop 'an error occurred while reading the parameter file' ! close parameter file call close_parameter_file @@ -1098,73 +1098,73 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD ! subsets used to save seismograms must not be larger than the whole time series, ! otherwise we waste memory - if(NTSTEP_BETWEEN_OUTPUT_SEISMOS > NSTEP) then + if (NTSTEP_BETWEEN_OUTPUT_SEISMOS > NSTEP) then NTSTEP_BETWEEN_OUTPUT_SEISMOS = NSTEP if (OUTPUT_SEISMOS_SAC_ALPHANUM .and. (mod(NTSTEP_BETWEEN_OUTPUT_SEISMOS,5)/=0)) & stop 'if OUTPUT_SEISMOS_SAC_ALPHANUM = .true. then modified NTSTEP_BETWEEN_OUTPUT_SEISMOS must be a multiple of 5' endif ! check that reals are either 4 or 8 bytes - if(CUSTOM_REAL /= SIZE_REAL .and. CUSTOM_REAL /= SIZE_DOUBLE) stop 'wrong size of CUSTOM_REAL for reals' + if (CUSTOM_REAL /= SIZE_REAL .and. CUSTOM_REAL /= SIZE_DOUBLE) stop 'wrong size of CUSTOM_REAL for reals' ! check that the parameter file is correct - if(NGNOD /= 27) stop 'number of control nodes must be 27' - if(NGNOD == 27 .and. NGNOD2D /= 9) stop 'elements with 27 points should have NGNOD2D = 9' + if (NGNOD /= 27) stop 'number of control nodes must be 27' + if (NGNOD == 27 .and. NGNOD2D /= 9) stop 'elements with 27 points should have NGNOD2D = 9' ! for the number of standard linear solids for attenuation - if(N_SLS /= 3) stop 'number of SLS must be 3' + if (N_SLS /= 3) stop 'number of SLS must be 3' ! check number of slices in each direction - if(NCHUNKS < 1) stop 'must have at least one chunk' + if (NCHUNKS < 1) stop 'must have at least one chunk' #ifdef USE_MPI - if(NPROC_XI < 2) stop 'NPROC_XI must be at least 2 for the MPI + GPU version' - if(NPROC_ETA < 2) stop 'NPROC_ETA must be at least 2 for the MPI + GPU version' + if (NPROC_XI < 2) stop 'NPROC_XI must be at least 2 for the MPI + GPU version' + if (NPROC_ETA < 2) stop 'NPROC_ETA must be at least 2 for the MPI + GPU version' #endif ! check number of chunks - if(NCHUNKS /= 1 .and. NCHUNKS /= 2 .and. NCHUNKS /= 3 .and. NCHUNKS /= 6) & + if (NCHUNKS /= 1 .and. NCHUNKS /= 2 .and. NCHUNKS /= 3 .and. NCHUNKS /= 6) & stop 'only one, two, three or six chunks can be meshed' ! check that the central cube can be included - if(INCLUDE_CENTRAL_CUBE .and. NCHUNKS /= 6) stop 'need six chunks to include central cube' + if (INCLUDE_CENTRAL_CUBE .and. NCHUNKS /= 6) stop 'need six chunks to include central cube' ! check that sphere can be cut into slices without getting negative Jacobian - if(NEX_XI < 48) stop 'NEX_XI must be greater than 48 to cut the sphere into slices with positive Jacobian' - if(NEX_ETA < 48) stop 'NEX_ETA must be greater than 48 to cut the sphere into slices with positive Jacobian' + if (NEX_XI < 48) stop 'NEX_XI must be greater than 48 to cut the sphere into slices with positive Jacobian' + if (NEX_ETA < 48) stop 'NEX_ETA must be greater than 48 to cut the sphere into slices with positive Jacobian' ! check that mesh can be coarsened in depth three or four times CUT_SUPERBRICK_XI=.false. CUT_SUPERBRICK_ETA=.false. if (SUPPRESS_CRUSTAL_MESH .and. .not. ADD_4TH_DOUBLING) then - if(mod(NEX_XI,8) /= 0) stop 'NEX_XI must be a multiple of 8' - if(mod(NEX_ETA,8) /= 0) stop 'NEX_ETA must be a multiple of 8' - if(mod(NEX_XI/4,NPROC_XI) /= 0) stop 'NEX_XI must be a multiple of 4*NPROC_XI' - if(mod(NEX_ETA/4,NPROC_ETA) /= 0) stop 'NEX_ETA must be a multiple of 4*NPROC_ETA' - if(mod(NEX_XI/8,NPROC_XI) /=0) CUT_SUPERBRICK_XI = .true. - if(mod(NEX_ETA/8,NPROC_ETA) /=0) CUT_SUPERBRICK_ETA = .true. + if (mod(NEX_XI,8) /= 0) stop 'NEX_XI must be a multiple of 8' + if (mod(NEX_ETA,8) /= 0) stop 'NEX_ETA must be a multiple of 8' + if (mod(NEX_XI/4,NPROC_XI) /= 0) stop 'NEX_XI must be a multiple of 4*NPROC_XI' + if (mod(NEX_ETA/4,NPROC_ETA) /= 0) stop 'NEX_ETA must be a multiple of 4*NPROC_ETA' + if (mod(NEX_XI/8,NPROC_XI) /=0) CUT_SUPERBRICK_XI = .true. + if (mod(NEX_ETA/8,NPROC_ETA) /=0) CUT_SUPERBRICK_ETA = .true. else if (SUPPRESS_CRUSTAL_MESH .or. .not. ADD_4TH_DOUBLING) then - if(mod(NEX_XI,16) /= 0) stop 'NEX_XI must be a multiple of 16' - if(mod(NEX_ETA,16) /= 0) stop 'NEX_ETA must be a multiple of 16' - if(mod(NEX_XI/8,NPROC_XI) /= 0) stop 'NEX_XI must be a multiple of 8*NPROC_XI' - if(mod(NEX_ETA/8,NPROC_ETA) /= 0) stop 'NEX_ETA must be a multiple of 8*NPROC_ETA' - if(mod(NEX_XI/16,NPROC_XI) /=0) CUT_SUPERBRICK_XI = .true. - if(mod(NEX_ETA/16,NPROC_ETA) /=0) CUT_SUPERBRICK_ETA = .true. + if (mod(NEX_XI,16) /= 0) stop 'NEX_XI must be a multiple of 16' + if (mod(NEX_ETA,16) /= 0) stop 'NEX_ETA must be a multiple of 16' + if (mod(NEX_XI/8,NPROC_XI) /= 0) stop 'NEX_XI must be a multiple of 8*NPROC_XI' + if (mod(NEX_ETA/8,NPROC_ETA) /= 0) stop 'NEX_ETA must be a multiple of 8*NPROC_ETA' + if (mod(NEX_XI/16,NPROC_XI) /=0) CUT_SUPERBRICK_XI = .true. + if (mod(NEX_ETA/16,NPROC_ETA) /=0) CUT_SUPERBRICK_ETA = .true. else - if(mod(NEX_XI,32) /= 0) stop 'NEX_XI must be a multiple of 32' - if(mod(NEX_ETA,32) /= 0) stop 'NEX_ETA must be a multiple of 32' - if(mod(NEX_XI/16,NPROC_XI) /= 0) stop 'NEX_XI must be a multiple of 16*NPROC_XI' - if(mod(NEX_ETA/16,NPROC_ETA) /= 0) stop 'NEX_ETA must be a multiple of 16*NPROC_ETA' - if(mod(NEX_XI/32,NPROC_XI) /=0) CUT_SUPERBRICK_XI = .true. - if(mod(NEX_ETA/32,NPROC_ETA) /=0) CUT_SUPERBRICK_ETA = .true. + if (mod(NEX_XI,32) /= 0) stop 'NEX_XI must be a multiple of 32' + if (mod(NEX_ETA,32) /= 0) stop 'NEX_ETA must be a multiple of 32' + if (mod(NEX_XI/16,NPROC_XI) /= 0) stop 'NEX_XI must be a multiple of 16*NPROC_XI' + if (mod(NEX_ETA/16,NPROC_ETA) /= 0) stop 'NEX_ETA must be a multiple of 16*NPROC_ETA' + if (mod(NEX_XI/32,NPROC_XI) /=0) CUT_SUPERBRICK_XI = .true. + if (mod(NEX_ETA/32,NPROC_ETA) /=0) CUT_SUPERBRICK_ETA = .true. endif ! check that topology is correct if more than two chunks - if(NCHUNKS > 2 .and. NEX_XI /= NEX_ETA) stop 'must have NEX_XI = NEX_ETA for more than two chunks' - if(NCHUNKS > 2 .and. NPROC_XI /= NPROC_ETA) stop 'must have NPROC_XI = NPROC_ETA for more than two chunks' + if (NCHUNKS > 2 .and. NEX_XI /= NEX_ETA) stop 'must have NEX_XI = NEX_ETA for more than two chunks' + if (NCHUNKS > 2 .and. NPROC_XI /= NPROC_ETA) stop 'must have NPROC_XI = NPROC_ETA for more than two chunks' ! check that IASP91, AK135, 1066A, JP1D or SEA1D is isotropic - if((REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91 .or. & + if ((REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91 .or. & REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135 .or. & REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A .or. & REFERENCE_1D_MODEL == REFERENCE_MODEL_JP1D .or. & @@ -1200,7 +1200,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD do ielem = 2,NER_TOPDDOUBLEPRIME_771 zval = RTOPDDOUBLEPRIME + ielem * (R771 - RTOPDDOUBLEPRIME) / dble(NER_TOPDDOUBLEPRIME_771) distance = abs(zval - (R_EARTH - DEPTH_SECOND_DOUBLING_OPTIMAL)) - if(distance < distance_min) then + if (distance < distance_min) then elem_doubling_mantle = ielem distance_min = distance DEPTH_SECOND_DOUBLING_REAL = R_EARTH - zval @@ -1215,7 +1215,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD do ielem = 4,NER_OUTER_CORE zval = RICB + ielem * (RCMB - RICB) / dble(NER_OUTER_CORE) distance = abs(zval - (R_EARTH - DEPTH_THIRD_DOUBLING_OPTIMAL)) - if(distance < distance_min) then + if (distance < distance_min) then elem_doubling_middle_outer_core = ielem distance_min = distance DEPTH_THIRD_DOUBLING_REAL = R_EARTH - zval @@ -1231,14 +1231,14 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD do ielem = 2,NER_OUTER_CORE-2 zval = RICB + ielem * (RCMB - RICB) / dble(NER_OUTER_CORE) distance = abs(zval - (R_EARTH - DEPTH_FOURTH_DOUBLING_OPTIMAL)) - if(distance < distance_min) then + if (distance < distance_min) then elem_doubling_bottom_outer_core = ielem distance_min = distance DEPTH_FOURTH_DOUBLING_REAL = R_EARTH - zval endif enddo ! make sure that the two doublings in the outer core are found in the right order - if(elem_doubling_bottom_outer_core >= elem_doubling_middle_outer_core) & + if (elem_doubling_bottom_outer_core >= elem_doubling_middle_outer_core) & stop 'error in location of the two doublings in the outer core' endif @@ -2053,13 +2053,13 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD ! theoretical number of spectral elements in radial direction do iter_region = IREGION_CRUST_MANTLE,IREGION_INNER_CORE - if(iter_region == IREGION_CRUST_MANTLE) then + if (iter_region == IREGION_CRUST_MANTLE) then ifirst_region = 1 ilast_region = 10 + layer_offset - else if(iter_region == IREGION_OUTER_CORE) then + else if (iter_region == IREGION_OUTER_CORE) then ifirst_region = 11 + layer_offset ilast_region = NUMBER_OF_MESH_LAYERS - 1 - else if(iter_region == IREGION_INNER_CORE) then + else if (iter_region == IREGION_INNER_CORE) then ifirst_region = NUMBER_OF_MESH_LAYERS ilast_region = NUMBER_OF_MESH_LAYERS else @@ -2113,13 +2113,13 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD ! exact number of surface elements for faces along XI and ETA do iter_region = IREGION_CRUST_MANTLE,IREGION_INNER_CORE - if(iter_region == IREGION_CRUST_MANTLE) then + if (iter_region == IREGION_CRUST_MANTLE) then ifirst_region = 1 ilast_region = 10 + layer_offset - else if(iter_region == IREGION_OUTER_CORE) then + else if (iter_region == IREGION_OUTER_CORE) then ifirst_region = 11 + layer_offset ilast_region = NUMBER_OF_MESH_LAYERS - 1 - else if(iter_region == IREGION_INNER_CORE) then + else if (iter_region == IREGION_INNER_CORE) then ifirst_region = NUMBER_OF_MESH_LAYERS ilast_region = NUMBER_OF_MESH_LAYERS else @@ -2288,13 +2288,13 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD ! exact number of spectral elements in each region do iter_region = IREGION_CRUST_MANTLE,IREGION_INNER_CORE - if(iter_region == IREGION_CRUST_MANTLE) then + if (iter_region == IREGION_CRUST_MANTLE) then ifirst_region = 1 ilast_region = 10 + layer_offset - else if(iter_region == IREGION_OUTER_CORE) then + else if (iter_region == IREGION_OUTER_CORE) then ifirst_region = 11 + layer_offset ilast_region = NUMBER_OF_MESH_LAYERS - 1 - else if(iter_region == IREGION_INNER_CORE) then + else if (iter_region == IREGION_INNER_CORE) then ifirst_region = NUMBER_OF_MESH_LAYERS ilast_region = NUMBER_OF_MESH_LAYERS else @@ -2324,12 +2324,12 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD NSPEC(iter_region) = tmp_sum enddo - if(INCLUDE_CENTRAL_CUBE) NSPEC(IREGION_INNER_CORE) = NSPEC(IREGION_INNER_CORE) + & + if (INCLUDE_CENTRAL_CUBE) NSPEC(IREGION_INNER_CORE) = NSPEC(IREGION_INNER_CORE) + & (NEX_PER_PROC_XI / ratio_divide_central_cube) * & (NEX_PER_PROC_ETA / ratio_divide_central_cube) * & (NEX_XI / ratio_divide_central_cube) - if(minval(NSPEC) <= 0) stop 'negative NSPEC, there is a problem somewhere' + if (minval(NSPEC) <= 0) stop 'negative NSPEC, there is a problem somewhere' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!! @@ -2369,7 +2369,7 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD NGLOB(:) = 0 ! in the inner core (no doubling region + eventually central cube) - if(INCLUDE_CENTRAL_CUBE) then + if (INCLUDE_CENTRAL_CUBE) then NGLOB(IREGION_INNER_CORE) = ((NEX_PER_PROC_XI/ratio_divide_central_cube) & *(NGLLX-1)+1)*((NEX_PER_PROC_ETA/ratio_divide_central_cube) & *(NGLLY-1)+1)*((NER_TOP_CENTRAL_CUBE_ICB + NEX_XI / ratio_divide_central_cube)*(NGLLZ-1)+1) @@ -2381,10 +2381,10 @@ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD ! in the crust-mantle and outercore do iter_region = IREGION_CRUST_MANTLE,IREGION_OUTER_CORE - if(iter_region == IREGION_CRUST_MANTLE) then + if (iter_region == IREGION_CRUST_MANTLE) then ifirst_region = 1 ilast_region = 10 + layer_offset - else if(iter_region == IREGION_OUTER_CORE) then + else if (iter_region == IREGION_OUTER_CORE) then ifirst_region = 11 + layer_offset ilast_region = NUMBER_OF_MESH_LAYERS - 1 else diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/read_value_parameters.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/read_value_parameters.f90 index 4e56312aa..c774144af 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/read_value_parameters.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/read_value_parameters.f90 @@ -107,17 +107,17 @@ subroutine read_next_line(string_read) do read(unit=IIN,fmt="(a100)",iostat=ios) string_read - if(ios /= 0) stop 'error while reading parameter file' + if (ios /= 0) stop 'error while reading parameter file' ! suppress leading white spaces, if any string_read = adjustl(string_read) ! suppress trailing carriage return (ASCII code 13) if any (e.g. if input text file coming from Windows/DOS) - if(index(string_read,achar(13)) > 0) string_read = string_read(1:index(string_read,achar(13))-1) + if (index(string_read,achar(13)) > 0) string_read = string_read(1:index(string_read,achar(13))-1) ! exit loop when we find the first line that is not a comment or a white line - if(len_trim(string_read) == 0) cycle - if(string_read(1:1) /= '#') exit + if (len_trim(string_read) == 0) cycle + if (string_read(1:1) /= '#') exit enddo @@ -125,11 +125,11 @@ subroutine read_next_line(string_read) string_read = string_read(1:len_trim(string_read)) ! suppress trailing comments, if any - if(index(string_read,'#') > 0) string_read = string_read(1:index(string_read,'#')-1) + if (index(string_read,'#') > 0) string_read = string_read(1:index(string_read,'#')-1) ! suppress leading junk (up to the first equal sign, included) index_equal_sign = index(string_read,'=') - if(index_equal_sign <= 1 .or. index_equal_sign == len_trim(string_read)) stop 'incorrect syntax detected in DATA/Par_file' + if (index_equal_sign <= 1 .or. index_equal_sign == len_trim(string_read)) stop 'incorrect syntax detected in DATA/Par_file' string_read = string_read(index_equal_sign + 1:len_trim(string_read)) ! suppress leading and trailing white spaces again, if any, after having suppressed the leading junk diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/recompute_jacobian.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/recompute_jacobian.f90 index 0a57b1638..939d36cb5 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/recompute_jacobian.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/recompute_jacobian.f90 @@ -61,7 +61,7 @@ subroutine recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z, & ! not necessarily a GLL point ! check that the parameter file is correct - if(NGNOD /= 27) stop 'elements should have 27 control nodes' + if (NGNOD /= 27) stop 'elements should have 27 control nodes' l1xi=HALF*xi*(xi-ONE) l2xi=ONE-xi**2 @@ -250,7 +250,7 @@ subroutine recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z, & jacobian = xxi*(yeta*zgamma-ygamma*zeta) - xeta*(yxi*zgamma-ygamma*zxi) + & xgamma*(yxi*zeta-yeta*zxi) - if(jacobian <= ZERO) stop '3D Jacobian undefined' + if (jacobian <= ZERO) stop '3D Jacobian undefined' ! invert the relation (Fletcher p. 50 vol. 2) xix=(yeta*zgamma-ygamma*zeta)/jacobian diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/reduce.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/reduce.f90 index c9b8c042a..5a52fc003 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/reduce.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/reduce.f90 @@ -41,18 +41,18 @@ subroutine reduce(theta,phi) th=theta ph=phi i=abs(int(ph/TWO_PI)) - if(phTWO_PI) ph=ph-i*TWO_PI + if (ph>TWO_PI) ph=ph-i*TWO_PI endif phi=ph - if(thPI) then + if (thPI) then i=int(th/PI) - if(th>ZERO) then - if(mod(i,2) /= 0) then + if (th>ZERO) then + if (mod(i,2) /= 0) then th=(i+1)*PI-th - if(phPI) stop 'theta out of range in reduce' + if (thetaPI) stop 'theta out of range in reduce' - if(phiTWO_PI) stop 'phi out of range in reduce' + if (phiTWO_PI) stop 'phi out of range in reduce' end subroutine reduce diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/rthetaphi_xyz.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/rthetaphi_xyz.f90 index 8df33a6b2..10aaa9afb 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/rthetaphi_xyz.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/rthetaphi_xyz.f90 @@ -37,17 +37,17 @@ subroutine xyz_2_rthetaphi(x,y,z,r,theta,phi) double precision xmesh,ymesh,zmesh ! distinguish between single and double precision for reals - if(CUSTOM_REAL == SIZE_REAL) then + if (CUSTOM_REAL == SIZE_REAL) then xmesh = dble(x) ymesh = dble(y) zmesh = dble(z) - if(zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE - if(zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE + if (zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE + if (zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE theta = sngl(datan2(dsqrt(xmesh*xmesh+ymesh*ymesh),zmesh)) - if(xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE - if(xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE + if (xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE + if (xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE phi = sngl(datan2(ymesh,xmesh)) r = sngl(dsqrt(xmesh**2 + ymesh**2 + zmesh**2)) @@ -58,11 +58,11 @@ subroutine xyz_2_rthetaphi(x,y,z,r,theta,phi) ymesh = y zmesh = z - if(zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE - if(zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE + if (zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE + if (zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE theta = datan2(dsqrt(xmesh*xmesh+ymesh*ymesh),zmesh) - if(xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE - if(xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE + if (xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE + if (xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE phi = datan2(ymesh,xmesh) r = dsqrt(xmesh**2 + ymesh**2 + zmesh**2) @@ -88,11 +88,11 @@ subroutine xyz_2_rthetaphi_dble(x,y,z,r,theta,phi) ymesh = y zmesh = z - if(zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE - if(zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE + if (zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE + if (zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE theta = datan2(dsqrt(xmesh*xmesh+ymesh*ymesh),zmesh) - if(xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE - if(xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE + if (xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE + if (xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE phi = datan2(ymesh,xmesh) r = dsqrt(xmesh**2 + ymesh**2 + zmesh**2) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/s362ani.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/s362ani.f90 index 5647f78b4..dcb21c73b 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/s362ani.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/s362ani.f90 @@ -34,16 +34,16 @@ subroutine evradker(depth,string,nker,vercof,dvercof,ierror) radius2=r0-depth+ddep upper=.false. lower=.false. - if(radius > rcmb.and.radius < r670) then + if (radius > rcmb.and.radius < r670) then lower=.true. - else if(radius >= r670.and.radius < rmoho) then + else if (radius >= r670.and.radius < rmoho) then upper=.true. endif upper_650=.false. lower_650=.false. - if(radius > rcmb.and.radius < r650) then + if (radius > rcmb.and.radius < r650) then lower_650=.true. - else if(radius >= r650.and.radius < rmoho) then + else if (radius >= r650.and.radius < rmoho) then upper_650=.true. endif do iker=1,nker @@ -51,11 +51,11 @@ subroutine evradker(depth,string,nker,vercof,dvercof,ierror) dvercof(iker)=0. enddo - if(string(1:16) == 'WDC+SPC_U4L8CHEB') then + if (string(1:16) == 'WDC+SPC_U4L8CHEB') then nupper=5 nlower=9 nskip=2 - if(upper) then + if (upper) then u=(radius+radius-rmoho-r670)/(rmoho-r670) u2=(radius2+radius2-rmoho-r670)/(rmoho-r670) ! write(6,"('upper mantle:',2f10.3)") u,u2 @@ -67,7 +67,7 @@ subroutine evradker(depth,string,nker,vercof,dvercof,ierror) do i=1+nskip,nskip+nupper dvercof(i)=(chebyshev2(i-nskip)-chebyshev(i-nskip))/ddep enddo - else if(lower) then + else if (lower) then u=(radius+radius-r670-rcmb)/(r670-rcmb) u2=(radius2+radius2-r670-rcmb)/(r670-rcmb) ! write(6,"('lower mantle:',2f10.3)") u,u2 @@ -81,7 +81,7 @@ subroutine evradker(depth,string,nker,vercof,dvercof,ierror) chebyshev(i-nskip-nupper))/ddep enddo endif - else if(string(1:13) == 'WDC+SHSVWM20A') then + else if (string(1:13) == 'WDC+SHSVWM20A') then nspl=20 splpts(1)=0. splpts(2)=50. @@ -109,8 +109,8 @@ subroutine evradker(depth,string,nker,vercof,dvercof,ierror) dvercof(i)=dvercof(i-20) enddo vercof(1)=1. - else if(string(1:16) == 'WDC+XBS_362_U6L8') then - if(upper) then + else if (string(1:16) == 'WDC+XBS_362_U6L8') then + if (upper) then nspl=6 splpts(1)=24.4 splpts(2)=100. @@ -119,7 +119,7 @@ subroutine evradker(depth,string,nker,vercof,dvercof,ierror) splpts(5)=500. splpts(6)=670. call vbspl(depth,nspl,splpts,vercof(2),dvercof(2)) - else if(lower) then + else if (lower) then nspl=8 splpts(1)=670. splpts(2)=820. @@ -134,8 +134,8 @@ subroutine evradker(depth,string,nker,vercof,dvercof,ierror) vercof(1)=1. ! vercof(16)=1. ! vercof(17)=1. -! else if(string(1:21) == 'WDC+ANI_362_U6L8_TOPO') then -! if(upper) then +! else if (string(1:21) == 'WDC+ANI_362_U6L8_TOPO') then +! if (upper) then ! nspl=6 ! splpts(1)=24.4 ! splpts(2)=100. @@ -148,7 +148,7 @@ subroutine evradker(depth,string,nker,vercof,dvercof,ierror) ! vercof(i)=vercof(i-14) ! dvercof(i)=dvercof(i-14) ! enddo -! else if(lower) then +! else if (lower) then ! nspl=8 ! splpts(1)=670. ! splpts(2)=820. @@ -165,12 +165,12 @@ subroutine evradker(depth,string,nker,vercof,dvercof,ierror) ! vercof(23)=1. ! vercof(24)=1. ! vercof(25)=1. - else if( & + else if ( & (string(1:lstr) == 'WDC+ANI_362_U6L8'.and.lstr == 16) & .or. & (string(1:lstr) == 'WDC+ANI_362_U6L8_TOPO'.and.lstr == 21) & ) then - if(upper) then + if (upper) then nspl=6 splpts(1)=24.4 splpts(2)=100. @@ -183,7 +183,7 @@ subroutine evradker(depth,string,nker,vercof,dvercof,ierror) vercof(i)=vercof(i-14) dvercof(i)=dvercof(i-14) enddo - else if(lower) then + else if (lower) then nspl=8 splpts(1)=670. splpts(2)=820. @@ -198,8 +198,8 @@ subroutine evradker(depth,string,nker,vercof,dvercof,ierror) vercof(1)=1. vercof(22)=1. vercof(23)=1. - else if(string(1:lstr) == 'WDC+WM_362_U6L8'.and.lstr == 15) then - if(upper) then + else if (string(1:lstr) == 'WDC+WM_362_U6L8'.and.lstr == 15) then + if (upper) then nspl=6 splpts(1)=24.4 splpts(2)=100. @@ -212,7 +212,7 @@ subroutine evradker(depth,string,nker,vercof,dvercof,ierror) vercof(i)=vercof(i-14) dvercof(i)=dvercof(i-14) enddo - else if(lower) then + else if (lower) then nspl=8 splpts(1)=670. splpts(2)=820. @@ -232,12 +232,12 @@ subroutine evradker(depth,string,nker,vercof,dvercof,ierror) vercof(30)=1. vercof(31)=1. vercof(32)=1. - else if( & + else if ( & (string(1:lstr) == 'WDC+ANI_362_U6L8_650'.and.lstr == 20) & .or. & (string(1:lstr) == 'WDC+ANI_362_U6L8_TOPO_650'.and.lstr == 25) & ) then - if(upper_650) then + if (upper_650) then nspl=6 splpts(1)=24.4 splpts(2)=100. @@ -250,7 +250,7 @@ subroutine evradker(depth,string,nker,vercof,dvercof,ierror) vercof(i)=vercof(i-14) dvercof(i)=dvercof(i-14) enddo - else if(lower_650) then + else if (lower_650) then nspl=8 splpts(1)=650. splpts(2)=820. @@ -265,9 +265,9 @@ subroutine evradker(depth,string,nker,vercof,dvercof,ierror) vercof(1)=1. vercof(22)=1. vercof(23)=1. - else if(string(1:lstr) == 'WDC+WM_362_U6L8_650' & + else if (string(1:lstr) == 'WDC+WM_362_U6L8_650' & .and.lstr == 19) then - if(upper_650) then + if (upper_650) then nspl=6 splpts(1)=24.4 splpts(2)=100. @@ -280,7 +280,7 @@ subroutine evradker(depth,string,nker,vercof,dvercof,ierror) vercof(i)=vercof(i-14) dvercof(i)=dvercof(i-14) enddo - else if(lower_650) then + else if (lower_650) then nspl=8 splpts(1)=650. splpts(2)=820. @@ -300,8 +300,8 @@ subroutine evradker(depth,string,nker,vercof,dvercof,ierror) vercof(30)=1. vercof(31)=1. vercof(32)=1. - else if(string(1:lstr) == 'WDC+U8L8_650'.and.lstr == 12) then - if(upper_650) then + else if (string(1:lstr) == 'WDC+U8L8_650'.and.lstr == 12) then + if (upper_650) then nspl=8 splpts(1)=24.4 splpts(2)=75. @@ -316,7 +316,7 @@ subroutine evradker(depth,string,nker,vercof,dvercof,ierror) vercof(i)=vercof(i-16) dvercof(i)=dvercof(i-16) enddo - else if(lower_650) then + else if (lower_650) then nspl=8 splpts(1)=650. splpts(2)=820. @@ -336,8 +336,8 @@ subroutine evradker(depth,string,nker,vercof,dvercof,ierror) vercof(34)=1. vercof(35)=1. vercof(36)=1. - else if(string(1:lstr) == 'WDC+U8L8_670'.and.lstr == 12) then - if(upper) then + else if (string(1:lstr) == 'WDC+U8L8_670'.and.lstr == 12) then + if (upper) then nspl=8 splpts(1)=24.4 splpts(2)=75. @@ -352,7 +352,7 @@ subroutine evradker(depth,string,nker,vercof,dvercof,ierror) vercof(i)=vercof(i-16) dvercof(i)=dvercof(i-16) enddo - else if(lower) then + else if (lower) then nspl=8 splpts(1)=670. splpts(2)=820. @@ -372,12 +372,12 @@ subroutine evradker(depth,string,nker,vercof,dvercof,ierror) vercof(34)=1. vercof(35)=1. vercof(36)=1. - else if( & + else if ( & (string(1:lstr) == 'WDC+U8L8_I1D_650'.and.lstr == 16) & .or. & (string(1:lstr) == 'WDC+U8L8_I3D_650'.and.lstr == 16) & ) then - if(upper_650) then + if (upper_650) then nspl=8 splpts(1)=24.4 splpts(2)=75. @@ -408,7 +408,7 @@ subroutine evradker(depth,string,nker,vercof,dvercof,ierror) vercof(i)=vercof(i-47) dvercof(i)=dvercof(i-47) enddo - else if(lower_650) then + else if (lower_650) then nspl=8 splpts(1)=650. splpts(2)=820. @@ -428,9 +428,9 @@ subroutine evradker(depth,string,nker,vercof,dvercof,ierror) vercof(34)=1. vercof(35)=1. vercof(36)=1. - else if((string(1:lstr) == 'WDC+I1D_650'.and.lstr == 11).or. & + else if ((string(1:lstr) == 'WDC+I1D_650'.and.lstr == 11).or. & (string(1:lstr) == 'WDC+I3D_650'.and.lstr == 11)) then - if(upper_650) then + if (upper_650) then nspl=8 splpts(1)=24.4 splpts(2)=75. @@ -461,7 +461,7 @@ subroutine evradker(depth,string,nker,vercof,dvercof,ierror) vercof(i)=vercof(i-83) dvercof(i)=dvercof(i-83) enddo - else if(lower_650) then + else if (lower_650) then nspl=8 splpts(1)=650. splpts(2)=820. @@ -497,8 +497,8 @@ subroutine evradker(depth,string,nker,vercof,dvercof,ierror) vercof(34)=1. vercof(35)=1. vercof(36)=1. - else if(string(1:lstr) == 'V16A4_V7A4'.and.lstr == 10) then - if(upper_650) then + else if (string(1:lstr) == 'V16A4_V7A4'.and.lstr == 10) then + if (upper_650) then nspl=8 splpts(1)=24.4 splpts(2)=75. @@ -521,7 +521,7 @@ subroutine evradker(depth,string,nker,vercof,dvercof,ierror) vercof(i)=vercof(i-29) dvercof(i)=dvercof(i-29) enddo - else if(lower_650) then + else if (lower_650) then nspl=8 splpts(1)=650. splpts(2)=820. @@ -563,7 +563,7 @@ subroutine chebyfun(u,kmax,f) 1.00196657023780,1.0015515913133,1.0012554932754,1.0010368069141, & 1.00087070107920,1.0007415648034 / - if(kmax > 13)then + if (kmax > 13) then write(*,"(' kmax exceeds the limit in chebyfun')") stop endif @@ -645,13 +645,13 @@ subroutine gt3dmodl(lu,targetfile, & xlaspl,xlospl,xraspl,ixlspl,coef, & hsplfile,refmodel,kernstri,desckern) - if(nhorpar <= maxhpa) then + if (nhorpar <= maxhpa) then numhpa=nhorpar else ierror=ierror+1 endif - if(nmodkern <= maxker) then + if (nmodkern <= maxker) then numker=nmodkern else ierror=ierror+1 @@ -662,7 +662,7 @@ subroutine gt3dmodl(lu,targetfile, & dskker(i)=desckern(i) do j=1,ncoefhor(ihpakern(i)) coe(j,i)=coef(j,i) -! if(j == 1) then +! if (j == 1) then ! write(6,"(e12.4)") coe(j,i) ! endif enddo @@ -672,7 +672,7 @@ subroutine gt3dmodl(lu,targetfile, & numcoe(i)=ncoefhor(i) lmxhpa(i)=lmaxhor(i) itypehpa(i)=ityphpar(i) - if(itypehpa(i) == 2) then + if (itypehpa(i) == 2) then do j=1,ncoefhor(i) itpspl(j,i)=ixlspl(j,i) xlatspl(j,i)=xlaspl(j,i) @@ -693,11 +693,11 @@ subroutine gt3dmodl(lu,targetfile, & enddo ivarkern(i)=0 do k=1,numvar - if(string(1:j) == varstr(k)(1:j)) then + if (string(1:j) == varstr(k)(1:j)) then ivarkern(i)=k endif enddo - if(ivarkern(i) == 0) then + if (ivarkern(i) == 0) then numvar=numvar+1 varstr(numvar)=string(1:j) ivarkern(i)=numvar @@ -748,44 +748,44 @@ subroutine rd3dmodl(lu,filename,ierror, & integer :: ncoef,i,ihor,ifst,ilst,ifst1,ios,lstr,nmodkern,idummy,nhorpar,lmax open(lu,file=filename,iostat=ios) - if(ios /= 0) then + if (ios /= 0) then stop 'error opening 3-d model' endif do while (ios == 0) read(lu,"(a)",iostat=ios) string lstr=len_trim(string) - if(ios == 0) then - if(string(1:16) == 'REFERENCE MODEL:') then + if (ios == 0) then + if (string(1:16) == 'REFERENCE MODEL:') then substr=string(17:lstr) ifst=1 ilst=len_trim(substr) do while (substr(ifst:ifst) == ' '.and.ifst < ilst) ifst=ifst+1 enddo - if(ilst-ifst <= 0) then + if (ilst-ifst <= 0) then stop 'error reading model 1' else refmodel=substr(ifst:ilst) endif - else if(string(1:11) == 'KERNEL SET:') then + else if (string(1:11) == 'KERNEL SET:') then substr=string(12:len_trim(string)) ifst=1 ilst=len_trim(substr) do while (substr(ifst:ifst) == ' '.and.ifst < ilst) ifst=ifst+1 enddo - if(ilst-ifst <= 0) then + if (ilst-ifst <= 0) then stop 'error reading model 2' else kernstri=substr(ifst:ilst) endif - else if(string(1:25) == 'RADIAL STRUCTURE KERNELS:') then + else if (string(1:25) == 'RADIAL STRUCTURE KERNELS:') then substr=string(26:len_trim(string)) read(substr,*,iostat=ierror) nmodkern - if(ierror /= 0) then + if (ierror /= 0) then stop 'error reading model 3' endif - else if(string(1:4) == 'DESC'.and.string(9:9) == ':') then + else if (string(1:4) == 'DESC'.and.string(9:9) == ':') then read(string(5:8),"(i4)") idummy substr=string(10:len_trim(string)) ifst=1 @@ -793,33 +793,33 @@ subroutine rd3dmodl(lu,filename,ierror, & do while (substr(ifst:ifst) == ' '.and.ifst < ilst) ifst=ifst+1 enddo - if(ilst-ifst <= 0) then + if (ilst-ifst <= 0) then stop 'error reading model 4' else desckern(idummy)=substr(ifst:ilst) endif - else if(string(1:29) == 'HORIZONTAL PARAMETERIZATIONS:') then + else if (string(1:29) == 'HORIZONTAL PARAMETERIZATIONS:') then substr=string(30:len_trim(string)) read(substr,*,iostat=ierror) nhorpar - if(ierror /= 0) then + if (ierror /= 0) then stop 'error reading model 5' endif - else if(string(1:4) == 'HPAR'.and.string(9:9) == ':') then + else if (string(1:4) == 'HPAR'.and.string(9:9) == ':') then read(string(5:8),"(i4)") idummy ifst=10 ilst=len_trim(string) do while (string(ifst:ifst) == ' '.and.ifst < ilst) ifst=ifst+1 enddo - if(ilst-ifst <= 0) then + if (ilst-ifst <= 0) then stop 'error reading model 6' - else if(string(ifst:ifst+19) == 'SPHERICAL HARMONICS,') then + else if (string(ifst:ifst+19) == 'SPHERICAL HARMONICS,') then substr=string(20+ifst:len_trim(string)) read(substr,*) lmax ityphpar(idummy)=1 lmaxhor(idummy)=lmax ncoefhor(idummy)=(lmax+1)**2 - else if(string(ifst:ifst+17) == 'SPHERICAL SPLINES,') then + else if (string(ifst:ifst+17) == 'SPHERICAL SPLINES,') then ifst1=ifst+18 ifst=len_trim(string) ilst=len_trim(string) @@ -840,7 +840,7 @@ subroutine rd3dmodl(lu,filename,ierror, & xlospl(i,idummy),xraspl(i,idummy) enddo endif - else if(string(1:4) == 'STRU'.and.string(9:9) == ':') then + else if (string(1:4) == 'STRU'.and.string(9:9) == ':') then read(string(5:8),"(i4)") idummy substr=string(10:len_trim(string)) read(substr,*) ihor @@ -903,19 +903,19 @@ subroutine read_model_s362ani(THREE_D_MODEL, & ! ------------------------------------- lu=1 ! --- log unit: input 3-D model - if(THREE_D_MODEL == THREE_D_MODEL_S362ANI) then + if (THREE_D_MODEL == THREE_D_MODEL_S362ANI) then modeldef='DATA/s362ani/S362ANI' - else if(THREE_D_MODEL == THREE_D_MODEL_S362WMANI) then + else if (THREE_D_MODEL == THREE_D_MODEL_S362WMANI) then modeldef='DATA/s362ani/S362WMANI' - else if(THREE_D_MODEL == THREE_D_MODEL_S362ANI_PREM) then + else if (THREE_D_MODEL == THREE_D_MODEL_S362ANI_PREM) then modeldef='DATA/s362ani/S362ANI_PREM' - else if(THREE_D_MODEL == THREE_D_MODEL_S29EA) then + else if (THREE_D_MODEL == THREE_D_MODEL_S29EA) then modeldef='DATA/s362ani/S2.9EA' else stop 'unknown 3D model in read_model_s362ani' endif inquire(file=modeldef,exist=exists) - if(exists) then + if (exists) then call gt3dmodl(lu,modeldef, & maxhpa,maxker,maxcoe, & numhpa,numker,numcoe,lmxhpa, & @@ -929,12 +929,12 @@ subroutine read_model_s362ani(THREE_D_MODEL, & ! --- check arrays - if(numker > maxker) stop 'numker > maxker' + if (numker > maxker) stop 'numker > maxker' do ihpa=1,numhpa - if(itypehpa(ihpa) == 1) then - if(lmxhpa(ihpa) > maxl) stop 'lmxhpa(ihpa) > maxl' - else if(itypehpa(ihpa) == 2) then - if(numcoe(ihpa) > maxcoe) stop 'numcoe(ihpa) > maxcoe' + if (itypehpa(ihpa) == 1) then + if (lmxhpa(ihpa) > maxl) stop 'lmxhpa(ihpa) > maxl' + else if (itypehpa(ihpa) == 2) then + if (numcoe(ihpa) > maxcoe) stop 'numcoe(ihpa) > maxcoe' else stop 'problem with itypehpa' endif @@ -970,22 +970,22 @@ subroutine splcon(xlat,xlon,nver,verlat,verlon,verrad,ncon,icon,con) ncon=0 do iver=1,nver - if(xlat > verlat(iver)-2.*verrad(iver)) then - if(xlat < verlat(iver)+2.*verrad(iver)) then + if (xlat > verlat(iver)-2.*verrad(iver)) then + if (xlat < verlat(iver)+2.*verrad(iver)) then ver8=xrad*(verlat(iver)) xla8=xrad*(xlat) dd=sin(ver8)*sin(xla8) dd=dd+cos(ver8)*cos(xla8)* cos(xrad*(xlon-verlon(iver))) dd=acos(dd)/xrad - if(dd > (verrad(iver))*2.d0) then + if (dd > (verrad(iver))*2.d0) then else ncon=ncon+1 icon(ncon)=iver rn=dd/(verrad(iver)) dr=rn-1.d0 - if(rn <= 1.d0) then + if (rn <= 1.d0) then con(ncon)=(0.75d0*rn-1.5d0)*(rn**2)+1.d0 - else if(rn > 1.d0) then + else if (rn > 1.d0) then con(ncon)=((-0.25d0*dr+0.75d0)*dr-0.75d0)*dr+0.25d0 else con(ncon)=0. @@ -1068,7 +1068,7 @@ subroutine subshsv(xcolat,xlon,xrad,dvsh,dvsv,dvph,dvpv, & depth=6371.0-xrad call evradker (depth,kerstr,numker,vercof,vercofd,ierror) - if(ierror /= 0) stop 'ierror evradker' + if (ierror /= 0) stop 'ierror evradker' ! --- loop over sv and sh (sv=0,sh=1) @@ -1079,10 +1079,10 @@ subroutine subshsv(xcolat,xlon,xrad,dvsh,dvsv,dvph,dvpv, & y=90.0-xcolat x=xlon do ihpa=1,numhpa - if(itypehpa(ihpa) == 1) then + if (itypehpa(ihpa) == 1) then lmax=lmxhpa(ihpa) call ylm(y,x,lmax,ylmcof(1,ihpa),wk1,wk2,wk3) - else if(itypehpa(ihpa) == 2) then + else if (itypehpa(ihpa) == 2) then numcof=numcoe(ihpa) call splcon(y,x,numcof,xlaspl(1,ihpa), & xlospl(1,ihpa),radspl(1,ihpa), & @@ -1103,30 +1103,30 @@ subroutine subshsv(xcolat,xlon,xrad,dvsh,dvsv,dvph,dvpv, & isel=0 lstr=len_trim(varstr(ivarkern(iker))) vstr=(varstr(ivarkern(iker))) - if(ieval == 1) then - if(vstr(1:lstr) == 'UM (SH+SV)*0.5,'.or. & + if (ieval == 1) then + if (vstr(1:lstr) == 'UM (SH+SV)*0.5,'.or. & vstr(1:lstr) == 'LM (SH+SV)*0.5,'.or. & vstr(1:lstr) == 'EA (SH+SV)*0.5,') then isel=1 endif - else if(ieval == 2) then - if(vstr(1:lstr) == 'UM SH-SV,'.or. & + else if (ieval == 2) then + if (vstr(1:lstr) == 'UM SH-SV,'.or. & vstr(1:lstr) == 'LM SH-SV,'.or. & vstr(1:lstr) == 'EA SH-SV,') then isel=1 endif endif - if(isel == 1) then - if(vercof(iker) /= 0.) then - if(itypehpa(ihpakern(iker)) == 1) then + if (isel == 1) then + if (vercof(iker) /= 0.) then + if (itypehpa(ihpakern(iker)) == 1) then ihpa=ihpakern(iker) nylm=(lmxhpa(ihpakern(iker))+1)**2 do i=1,nylm value=value+vercof(iker)*ylmcof(i,ihpa) & *coe(i,iker) enddo - else if(itypehpa(ihpakern(iker)) == 2) then + else if (itypehpa(ihpakern(iker)) == 2) then ihpa=ihpakern(iker) do i=1,nconpt(ihpa) iver=iconpt(i,ihpa) @@ -1146,9 +1146,9 @@ subroutine subshsv(xcolat,xlon,xrad,dvsh,dvsv,dvph,dvpv, & ! --- evaluate perturbations in vsh and vsv - if(ish == 1) then + if (ish == 1) then vsh3drel=valu(1)+0.5*valu(2) - else if(ish == 0) then + else if (ish == 0) then vsv3drel=valu(1)-0.5*valu(2) else stop 'something wrong' @@ -1230,10 +1230,10 @@ subroutine subtopo(xcolat,xlon,topo410,topo650, & y=90.0-xcolat x=xlon do ihpa=1,numhpa - if(itypehpa(ihpa) == 1) then + if (itypehpa(ihpa) == 1) then lmax=lmxhpa(ihpa) call ylm(y,x,lmax,ylmcof(1,ihpa),wk1,wk2,wk3) - else if(itypehpa(ihpa) == 2) then + else if (itypehpa(ihpa) == 2) then numcof=numcoe(ihpa) call splcon(y,x,numcof,xlaspl(1,ihpa), & xlospl(1,ihpa),radspl(1,ihpa), & @@ -1254,24 +1254,24 @@ subroutine subtopo(xcolat,xlon,topo410,topo650, & isel=0 lstr=len_trim(varstr(ivarkern(iker))) vstr=(varstr(ivarkern(iker))) - if(ieval == 1) then - if(vstr(1:lstr) == 'Topo 400,') then + if (ieval == 1) then + if (vstr(1:lstr) == 'Topo 400,') then isel=1 endif - else if(ieval == 2) then - if(vstr(1:lstr) == 'Topo 670,') then + else if (ieval == 2) then + if (vstr(1:lstr) == 'Topo 670,') then isel=1 endif endif - if(isel == 1) then - if(itypehpa(ihpakern(iker)) == 1) then + if (isel == 1) then + if (itypehpa(ihpakern(iker)) == 1) then ihpa=ihpakern(iker) nylm=(lmxhpa(ihpakern(iker))+1)**2 do i=1,nylm value=value+ylmcof(i,ihpa)*coe(i,iker) enddo - else if(itypehpa(ihpakern(iker)) == 2) then + else if (itypehpa(ihpakern(iker)) == 2) then ihpa=ihpakern(iker) do i=1,nconpt(ihpa) iver=iconpt(i,ihpa) @@ -1324,15 +1324,15 @@ subroutine vbspl(x,np,xarr,splcon,splcond) ik=1 do while(interval == 0.and.ik < np) ik=ik+1 - if(x >= xarr(ik-1).and.x <= xarr(ik)) interval=ik-1 + if (x >= xarr(ik-1).and.x <= xarr(ik)) interval=ik-1 enddo - if(x > xarr(np)) then + if (x > xarr(np)) then interval=np endif - if(interval == 0) then + if (interval == 0) then ! write(6,"('low value:',2f10.3)") x,xarr(1) - else if(interval > 0.and.interval < np) then + else if (interval > 0.and.interval < np) then ! write(6,"('bracket:',i5,3f10.3)") interval,xarr(interval),x,xarr(interval+1) else ! write(6,"('high value:',2f10.3)") xarr(np),x @@ -1341,7 +1341,7 @@ subroutine vbspl(x,np,xarr,splcon,splcond) do ib=1,np val=0. vald=0. - if(ib == 1) then + if (ib == 1) then r1=(x-xarr(1))/(xarr(2)-xarr(1)) r2=(xarr(3)-x)/(xarr(3)-xarr(1)) @@ -1363,14 +1363,14 @@ subroutine vbspl(x,np,xarr,splcon,splcond) r12d=-1./(xarr(3)-xarr(2)) r13d=-1./(xarr(2)-xarr(1)) - if(interval == ib.or.interval == 0) then - if(iflag == 0) then + if (interval == ib.or.interval == 0) then + if (iflag == 0) then val=r1*r4*r10 + r2*r5*r10 + r2*r6*r11 +r13**3 vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d vald=vald+3.*r13d*r13**2 - else if(iflag == 1) then + else if (iflag == 1) then val=0.6667*(r1*r4*r10 + r2*r5*r10 + r2*r6*r11 & + 1.5*r13**3) vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d @@ -1379,11 +1379,11 @@ subroutine vbspl(x,np,xarr,splcon,splcond) vald=vald+4.5*r13d*r13**2 vald=0.6667*vald endif - else if(interval == ib+1) then - if(iflag == 0) then + else if (interval == ib+1) then + if (iflag == 0) then val=r2*r6*r12 vald=r2d*r6*r12+r2*r6d*r12+r2*r6*r12d - else if(iflag == 1) then + else if (iflag == 1) then val=0.6667*r2*r6*r12 vald=0.6667*(r2d*r6*r12+r2*r6d*r12+r2*r6*r12d) endif @@ -1391,7 +1391,7 @@ subroutine vbspl(x,np,xarr,splcon,splcond) val=0. endif - else if(ib == 2) then + else if (ib == 2) then rr1=(x-xarr(1))/(xarr(2)-xarr(1)) rr2=(xarr(3)-x)/(xarr(3)-xarr(1)) @@ -1435,12 +1435,12 @@ subroutine vbspl(x,np,xarr,splcon,splcond) r11d=1./(xarr(ib+1)-xarr(ib)) r12d=-1./(xarr(ib+2)-xarr(ib+1)) - if(interval == ib-1.or.interval == 0) then + if (interval == ib-1.or.interval == 0) then val=r1*r3*r8 + r1*r4*r9 + r2*r5*r9 vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d - if(iflag == 1) then + if (iflag == 1) then val=val+0.3333*(rr1*rr4*rr10 + rr2*rr5*rr10 + & rr2*rr6*rr11) vald=vald+0.3333*(rr1d*rr4*rr10+rr1*rr4d*rr10+ & @@ -1450,23 +1450,23 @@ subroutine vbspl(x,np,xarr,splcon,splcond) vald=vald+0.3333*(rr2d*rr6*rr11+rr2*rr6d*rr11+ & rr2*rr6*rr11d) endif - else if(interval == ib) then + else if (interval == ib) then val=r1*r4*r10 + r2*r5*r10 + r2*r6*r11 vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d - if(iflag == 1) then + if (iflag == 1) then val=val+0.3333*rr2*rr6*rr12 vald=vald+0.3333*(rr2d*rr6*rr12+rr2*rr6d*rr12+ & rr2*rr6*rr12d) endif - else if(interval == ib+1) then + else if (interval == ib+1) then val=r2*r6*r12 vald=r2d*r6*r12+r2*r6d*r12+r2*r6*r12d else val=0. endif - else if(ib == np-1) then + else if (ib == np-1) then rr1=(x-xarr(np-2))/(xarr(np)-xarr(np-2)) rr2=(xarr(np)-x)/(xarr(np)-xarr(np-1)) @@ -1510,25 +1510,25 @@ subroutine vbspl(x,np,xarr,splcon,splcond) r10d=-1./(xarr(ib+1)-xarr(ib)) r11d=1./(xarr(ib+1)-xarr(ib)) - if(interval == ib-2) then + if (interval == ib-2) then val=r1*r3*r7 vald=r1d*r3*r7+r1*r3d*r7+r1*r3*r7d - else if(interval == ib-1) then + else if (interval == ib-1) then val=r1*r3*r8 + r1*r4*r9 + r2*r5*r9 vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d - if(iflag == 1) then + if (iflag == 1) then val=val+0.3333*rr1*rr3*rr7 vald=vald+0.3333*(rr1d*rr3*rr7+rr1*rr3d*rr7+ & rr1*rr3*rr7d) endif - else if(interval == ib.or.interval == np) then + else if (interval == ib.or.interval == np) then val=r1*r4*r10 + r2*r5*r10 + r2*r6*r11 vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d - if(iflag == 1) then + if (iflag == 1) then val=val+0.3333*(rr1*rr3*rr8 + rr1*rr4*rr9 + & rr2*rr5*rr9) vald=vald+0.3333*(rr1d*rr3*rr8+rr1*rr3d*rr8+ & @@ -1541,7 +1541,7 @@ subroutine vbspl(x,np,xarr,splcon,splcond) else val=0. endif - else if(ib == np) then + else if (ib == np) then r1=(x-xarr(np-2))/(xarr(np)-xarr(np-2)) r2=(xarr(np)-x)/(xarr(np)-xarr(np-1)) @@ -1563,22 +1563,22 @@ subroutine vbspl(x,np,xarr,splcon,splcond) r9d=1./(xarr(np)-xarr(np-1)) r13d=1./(xarr(np)-xarr(np-1)) - if(interval == np-2) then - if(iflag == 0) then + if (interval == np-2) then + if (iflag == 0) then val=r1*r3*r7 vald=r1d*r3*r7+r1*r3d*r7+r1*r3*r7d - else if(iflag == 1) then + else if (iflag == 1) then val=0.6667*r1*r3*r7 vald=0.6667*(r1d*r3*r7+r1*r3d*r7+r1*r3*r7d) endif - else if(interval == np-1.or.interval == np) then - if(iflag == 0) then + else if (interval == np-1.or.interval == np) then + if (iflag == 0) then val=r1*r3*r8 + r1*r4*r9 + r2*r5*r9 + r13**3 vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d vald=vald+3.*r13d*r13**2 - else if(iflag == 1) then + else if (iflag == 1) then val=0.6667*(r1*r3*r8 + r1*r4*r9 + r2*r5*r9 + & 1.5*r13**3) vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d @@ -1618,20 +1618,20 @@ subroutine vbspl(x,np,xarr,splcon,splcond) r11d=1./(xarr(ib+1)-xarr(ib)) r12d=-1./(xarr(ib+2)-xarr(ib+1)) - if(interval == ib-2) then + if (interval == ib-2) then val=r1*r3*r7 vald=r1d*r3*r7+r1*r3d*r7+r1*r3*r7d - else if(interval == ib-1) then + else if (interval == ib-1) then val=r1*r3*r8 + r1*r4*r9 + r2*r5*r9 vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d - else if(interval == ib) then + else if (interval == ib) then val=r1*r4*r10 + r2*r5*r10 + r2*r6*r11 vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d - else if(interval == ib+1) then + else if (interval == ib+1) then val=r2*r6*r12 vald=r2d*r6*r12+r2*r6d*r12+r2*r6*r12d else @@ -1683,7 +1683,7 @@ subroutine ylm(XLAT,XLON,LMAX,Y,WK1,WK2,WK3) TEMP=FAC*CMPLX(WK1(IM),0.) IND=IND+1 Y(IND)=REAL(TEMP) - IF(IM == 1) GOTO 20 + if (IM == 1) goto 20 IND=IND+1 Y(IND)=AIMAG(TEMP) 20 FAC=FAC*DFAC @@ -1729,15 +1729,15 @@ subroutine legndr(THETA,L,M,X,XP,XCOSEC) XP(I)=0. enddo - IF(L > 1.and.ABS(THETA) > 1.E-5) GO TO 3 + if (L > 1.and.ABS(THETA) > 1.E-5) goto 3 X(1)=FCT - IF(L == 0) RETURN + if (L == 0) RETURN X(1)=CT*FCT X(2)=-ST*FCT/DSFL3 XP(1)=-ST*FCT XP(2)=-.5D0*CT*FCT*DSFL3 - IF(ABS(THETA) < 1.E-5) XCOSEC(2)=XP(2) - IF(ABS(THETA) >= 1.E-5) XCOSEC(2)=X(2)/ST + if (ABS(THETA) < 1.E-5) XCOSEC(2)=XP(2) + if (ABS(THETA) >= 1.E-5) XCOSEC(2)=X(2)/ST RETURN 3 X1=1.D0 @@ -1762,7 +1762,7 @@ subroutine legndr(THETA,L,M,X,XP,XCOSEC) XCOSEC(2)=X(2)*COSEC XP(2)=-XP(2)/SFL3 SUM=SUM+2.D0*X(2)*X(2) - IF(SUM-COMPAR > SMALL) RETURN + if (SUM-COMPAR > SMALL) RETURN X1=X3 X2=-X2/DSQRT(dble(L*(L+1))) @@ -1773,7 +1773,7 @@ subroutine legndr(THETA,L,M,X,XP,XCOSEC) XM=K X3=-(2.D0*COT*(XM-1.D0)*X2+F2*X1)/F1 SUM=SUM+2.D0*X3*X3 - IF(SUM-COMPAR > SMALL.and.I /= LP1) RETURN + if (SUM-COMPAR > SMALL.and.I /= LP1) RETURN X(I)=X3 XCOSEC(I)=X(I)*COSEC X1=X2 diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/save_arrays_solver.F90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/save_arrays_solver.F90 index 64fba654b..a1082f1b2 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/save_arrays_solver.F90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/save_arrays_solver.F90 @@ -59,7 +59,7 @@ subroutine save_arrays_solver(prname,xix,xiy,xiz,etax,etay,etaz,gammax,gammay,ga ! we perform the calculation in single precision rather than integer ! to avoid integer overflow in the case of very large meshes memory_size = 4. * ((3.*NDIM + 1.) * NGLOB + 12. * real(NGLLX*NGLLY*NGLLZ)*real(NSPEC)) - if(myrank == 0) then + if (myrank == 0) then write(IMAIN,*) write(IMAIN,*) 'approximate total memory size that will be used by the solver in each slice = ',memory_size/1024./1024.,' Mb' write(IMAIN,*) 'i.e. = ',memory_size/1024./1024./1024.,' Gb' diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/save_header_file.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/save_header_file.f90 index cf11c94f0..d656f31bc 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/save_header_file.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/save_header_file.f90 @@ -116,7 +116,7 @@ subroutine save_header_file(NSPEC,nglob,NEX_XI,NEX_ETA,NPROC,NPROCTOT, & write(IOUT,*) '!' ! the central cube is counted 6 times, therefore remove 5 times - if(INCLUDE_CENTRAL_CUBE) then + if (INCLUDE_CENTRAL_CUBE) then write(IOUT,*) '! these statistics include the central cube' subtract_central_cube_elems = 5.d0 * dble((NEX_XI/8))**3 subtract_central_cube_points = 5.d0 * (dble(NEX_XI/8)*dble(NGLLX-1)+1.d0)**3 @@ -148,7 +148,7 @@ subroutine save_header_file(NSPEC,nglob,NEX_XI,NEX_ETA,NPROC,NPROCTOT, & write(IOUT,*) '!' ! display location of chunk if regional run - if(NCHUNKS /= 6) then + if (NCHUNKS /= 6) then write(IOUT,*) '! position of the mesh chunk at the surface:' write(IOUT,*) '! -----------------------------------------' @@ -209,7 +209,7 @@ subroutine save_header_file(NSPEC,nglob,NEX_XI,NEX_ETA,NPROC,NPROCTOT, & ! convert geocentric to geographic colatitude colat_corner=PI/2.0d0-datan(1.006760466d0*dcos(theta_corner)/dmax1(TINYVAL,dsin(theta_corner))) - if(phi_corner>PI) phi_corner=phi_corner-TWO_PI + if (phi_corner>PI) phi_corner=phi_corner-TWO_PI ! compute real position of the source lat = (PI/2.0d0-colat_corner)*180.0d0/PI @@ -318,56 +318,56 @@ subroutine save_header_file(NSPEC,nglob,NEX_XI,NEX_ETA,NPROC,NPROCTOT, & ! this to allow for code elimination by compiler in solver for performance - if(TRANSVERSE_ISOTROPY) then + if (TRANSVERSE_ISOTROPY) then write(IOUT,*) 'logical, parameter :: TRANSVERSE_ISOTROPY_VAL = .true.' else write(IOUT,*) 'logical, parameter :: TRANSVERSE_ISOTROPY_VAL = .false.' endif write(IOUT,*) - if(ANISOTROPIC_3D_MANTLE) then + if (ANISOTROPIC_3D_MANTLE) then write(IOUT,*) 'logical, parameter :: ANISOTROPIC_3D_MANTLE_VAL = .true.' else write(IOUT,*) 'logical, parameter :: ANISOTROPIC_3D_MANTLE_VAL = .false.' endif write(IOUT,*) - if(ANISOTROPIC_INNER_CORE) then + if (ANISOTROPIC_INNER_CORE) then write(IOUT,*) 'logical, parameter :: ANISOTROPIC_INNER_CORE_VAL = .true.' else write(IOUT,*) 'logical, parameter :: ANISOTROPIC_INNER_CORE_VAL = .false.' endif write(IOUT,*) - if(ATTENUATION) then + if (ATTENUATION) then write(IOUT,*) 'logical, parameter :: ATTENUATION_VAL = .true.' else write(IOUT,*) 'logical, parameter :: ATTENUATION_VAL = .false.' endif write(IOUT,*) - if(ATTENUATION_3D) then + if (ATTENUATION_3D) then write(IOUT,*) 'logical, parameter :: ATTENUATION_3D_VAL = .true.' else write(IOUT,*) 'logical, parameter :: ATTENUATION_3D_VAL = .false.' endif write(IOUT,*) - if(ELLIPTICITY) then + if (ELLIPTICITY) then write(IOUT,*) 'logical, parameter :: ELLIPTICITY_VAL = .true.' else write(IOUT,*) 'logical, parameter :: ELLIPTICITY_VAL = .false.' endif write(IOUT,*) - if(GRAVITY) then + if (GRAVITY) then write(IOUT,*) 'logical, parameter :: GRAVITY_VAL = .true.' else write(IOUT,*) 'logical, parameter :: GRAVITY_VAL = .false.' endif write(IOUT,*) - if(ROTATION) then + if (ROTATION) then write(IOUT,*) 'logical, parameter :: ROTATION_VAL = .true.' else write(IOUT,*) 'logical, parameter :: ROTATION_VAL = .false.' @@ -395,15 +395,15 @@ subroutine save_header_file(NSPEC,nglob,NEX_XI,NEX_ETA,NPROC,NPROCTOT, & write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_XY_VAL = ', & max(NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE)) - if(NCHUNKS == 1 .or. NCHUNKS == 2) then + if (NCHUNKS == 1 .or. NCHUNKS == 2) then NCORNERSCHUNKS = 1 NUM_FACES = 1 NUM_MSG_TYPES = 1 - else if(NCHUNKS == 3) then + else if (NCHUNKS == 3) then NCORNERSCHUNKS = 1 NUM_FACES = 1 NUM_MSG_TYPES = 3 - else if(NCHUNKS == 6) then + else if (NCHUNKS == 6) then NCORNERSCHUNKS = 8 NUM_FACES = 4 NUM_MSG_TYPES = 3 @@ -412,8 +412,8 @@ subroutine save_header_file(NSPEC,nglob,NEX_XI,NEX_ETA,NPROC,NPROCTOT, & write(IOUT,*) 'integer, parameter :: NUMMSGS_FACES_VAL = ',NPROC_XI*NUM_FACES*NUM_MSG_TYPES write(IOUT,*) 'integer, parameter :: NCORNERSCHUNKS_VAL = ',NCORNERSCHUNKS - if(ATTENUATION) then - if(ATTENUATION_3D) then + if (ATTENUATION) then + if (ATTENUATION_3D) then att1 = NGLLX att2 = NGLLY att3 = NGLLZ diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/sea99_s_model.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/sea99_s_model.f90 index 9cdfe8284..5728fb78a 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/sea99_s_model.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/sea99_s_model.f90 @@ -125,7 +125,7 @@ subroutine sea99_s_model(radius,theta,phi,dvs,SEA99M_V) if (dep <= SEA99M_V%sea99_depth(i)) then id1 = i-1 xd1 = (dep-SEA99M_V%sea99_depth(i-1)) / (SEA99M_V%sea99_depth(i) - SEA99M_V%sea99_depth(i-1)) - go to 1 + goto 1 endif enddo endif @@ -150,7 +150,7 @@ subroutine sea99_s_model(radius,theta,phi,dvs,SEA99M_V) ddd(i) = dd1 + yyy*xxx enddo dvs = ddd(1) + (ddd(2)-ddd(1)) * xd1 - if(dvs>1.d0) dvs=0.0d0 + if (dvs>1.d0) dvs=0.0d0 end subroutine sea99_s_model diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/spline_routines.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/spline_routines.f90 index 71fcb356e..edf6d97a5 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/spline_routines.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/spline_routines.f90 @@ -108,7 +108,7 @@ subroutine spline_evaluation(xpoint,ypoint,spline_coefficients,npoint,x_evaluate do while (index_higher - index_lower > 1) ! compute the middle of the interval index_loop = (index_higher + index_lower) / 2 - if(xpoint(index_loop) > x_evaluate_spline) then + if (xpoint(index_loop) > x_evaluate_spline) then index_higher = index_loop else index_lower = index_loop @@ -117,7 +117,7 @@ subroutine spline_evaluation(xpoint,ypoint,spline_coefficients,npoint,x_evaluate ! test that the interval obtained does not have a size of zero ! (this could happen for instance in the case of duplicates in the input list of points) - if(xpoint(index_higher) == xpoint(index_lower)) stop 'incorrect interval found in spline evaluation' + if (xpoint(index_higher) == xpoint(index_lower)) stop 'incorrect interval found in spline evaluation' coef1 = (xpoint(index_higher) - x_evaluate_spline) / (xpoint(index_higher) - xpoint(index_lower)) coef2 = (x_evaluate_spline - xpoint(index_lower)) / (xpoint(index_higher) - xpoint(index_lower)) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/topo_bathy.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/topo_bathy.f90 index 51bcf3d37..2602bb1b4 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/topo_bathy.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/topo_bathy.f90 @@ -45,18 +45,18 @@ subroutine get_topo_bathy(xlat,xlon,value,ibathy_topo) double precision xlo xlo = xlon - if(xlon < 0.d0) xlo = xlo + 360.d0 + if (xlon < 0.d0) xlo = xlo + 360.d0 ! compute number of samples per degree samples_per_degree_topo = dble(RESOLUTION_TOPO_FILE) / 60.d0 ! compute offset in data file and avoid edge effects iadd1 = 1 + int((90.d0-xlat)/samples_per_degree_topo) - if(iadd1 < 1) iadd1 = 1 - if(iadd1 > NY_BATHY) iadd1 = NY_BATHY + if (iadd1 < 1) iadd1 = 1 + if (iadd1 > NY_BATHY) iadd1 = NY_BATHY iel1 = int(xlo/samples_per_degree_topo) - if(iel1 <= 0 .or. iel1 > NX_BATHY) iel1 = NX_BATHY + if (iel1 <= 0 .or. iel1 > NX_BATHY) iel1 = NX_BATHY ! convert integer value to double precision value = dble(ibathy_topo(iel1,iadd1)) @@ -90,11 +90,11 @@ subroutine read_topo_bathy_file(ibathy_topo) read(13,*) ibathy_topo(itopo_x,itopo_y) ! impose maximum height of mountains, to suppress oscillations in Himalaya etc. - if(USE_MAXIMUM_HEIGHT_TOPO .and. ibathy_topo(itopo_x,itopo_y) > MAXIMUM_HEIGHT_TOPO) & + if (USE_MAXIMUM_HEIGHT_TOPO .and. ibathy_topo(itopo_x,itopo_y) > MAXIMUM_HEIGHT_TOPO) & ibathy_topo(itopo_x,itopo_y) = MAXIMUM_HEIGHT_TOPO ! impose maximum depth of oceans, to suppress oscillations near deep trenches - if(USE_MAXIMUM_DEPTH_OCEANS .and. ibathy_topo(itopo_x,itopo_y) < MAXIMUM_DEPTH_OCEANS) & + if (USE_MAXIMUM_DEPTH_OCEANS .and. ibathy_topo(itopo_x,itopo_y) < MAXIMUM_DEPTH_OCEANS) & ibathy_topo(itopo_x,itopo_y) = MAXIMUM_DEPTH_OCEANS enddo diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/write_AVS_DX_global_chunks_data.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/write_AVS_DX_global_chunks_data.f90 index 481d196ed..978b9e42d 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/write_AVS_DX_global_chunks_data.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/write_AVS_DX_global_chunks_data.f90 @@ -152,7 +152,7 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & ! mark global AVS or DX points do ispec=1,nspec ! only if on face - if(iboun(1,ispec) .or. iboun(2,ispec) .or. & + if (iboun(1,ispec) .or. iboun(2,ispec) .or. & iboun(3,ispec) .or. iboun(4,ispec)) then iglobval(1)=ibool(1,1,1,ispec) iglobval(2)=ibool(NGLLX,1,1,ispec) @@ -164,7 +164,7 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & iglobval(8)=ibool(1,NGLLY,NGLLZ,ispec) ! face xi = xi_min - if(iboun(1,ispec)) then + if (iboun(1,ispec)) then nspecface = nspecface + 1 mask_ibool(iglobval(1)) = .true. mask_ibool(iglobval(4)) = .true. @@ -173,7 +173,7 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & endif ! face xi = xi_max - if(iboun(2,ispec)) then + if (iboun(2,ispec)) then nspecface = nspecface + 1 mask_ibool(iglobval(2)) = .true. mask_ibool(iglobval(3)) = .true. @@ -182,7 +182,7 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & endif ! face eta = eta_min - if(iboun(3,ispec)) then + if (iboun(3,ispec)) then nspecface = nspecface + 1 mask_ibool(iglobval(1)) = .true. mask_ibool(iglobval(2)) = .true. @@ -191,7 +191,7 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & endif ! face eta = eta_max - if(iboun(4,ispec)) then + if (iboun(4,ispec)) then nspecface = nspecface + 1 mask_ibool(iglobval(4)) = .true. mask_ibool(iglobval(3)) = .true. @@ -215,7 +215,7 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & numpoin = 0 do ispec=1,nspec ! only if on face - if(iboun(1,ispec) .or. iboun(2,ispec) .or. & + if (iboun(1,ispec) .or. iboun(2,ispec) .or. & iboun(3,ispec) .or. iboun(4,ispec)) then iglobval(1)=ibool(1,1,1,ispec) iglobval(2)=ibool(NGLLX,1,1,ispec) @@ -227,9 +227,9 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & iglobval(8)=ibool(1,NGLLY,NGLLZ,ispec) ! face xi = xi_min - if(iboun(1,ispec)) then + if (iboun(1,ispec)) then - if(.not. mask_ibool(iglobval(1))) then + if (.not. mask_ibool(iglobval(1))) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglobval(1)) = numpoin write(10,*) numpoin,sngl(xstore(1,1,1,ispec)), & @@ -237,17 +237,17 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & vmax = sqrt((kappavstore(1,1,1,ispec)+4.*muvstore(1,1,1,ispec)/3.)/rhostore(1,1,1,ispec)) vmin = sqrt(muvstore(1,1,1,ispec)/rhostore(1,1,1,ispec)) ! particular case of the outer core (muvstore contains 1/rho) - if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then + if (idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then r = dsqrt(xstore(1,1,1,ispec)**2 + ystore(1,1,1,ispec)**2 + zstore(1,1,1,ispec)**2) call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec)) vmax = vp vmin = vp endif - if(vmin == 0.0) vmin=vmax + if (vmin == 0.0) vmin=vmax write(11,*) numpoin,vmin,vmax endif - if(.not. mask_ibool(iglobval(4))) then + if (.not. mask_ibool(iglobval(4))) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglobval(4)) = numpoin write(10,*) numpoin,sngl(xstore(1,NGLLY,1,ispec)), & @@ -255,17 +255,17 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & vmax = sqrt((kappavstore(1,NGLLY,1,ispec)+4.*muvstore(1,NGLLY,1,ispec)/3.)/rhostore(1,NGLLY,1,ispec)) vmin = sqrt(muvstore(1,NGLLY,1,ispec)/rhostore(1,NGLLY,1,ispec)) ! particular case of the outer core (muvstore contains 1/rho) - if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then + if (idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then r = dsqrt(xstore(1,NGLLY,1,ispec)**2 + ystore(1,NGLLY,1,ispec)**2 + zstore(1,NGLLY,1,ispec)**2) call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec)) vmax = vp vmin = vp endif - if(vmin == 0.0) vmin=vmax + if (vmin == 0.0) vmin=vmax write(11,*) numpoin,vmin,vmax endif - if(.not. mask_ibool(iglobval(8))) then + if (.not. mask_ibool(iglobval(8))) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglobval(8)) = numpoin write(10,*) numpoin,sngl(xstore(1,NGLLY,NGLLZ,ispec)), & @@ -273,17 +273,17 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & vmax = sqrt((kappavstore(1,NGLLY,NGLLZ,ispec)+4.*muvstore(1,NGLLY,NGLLZ,ispec)/3.)/rhostore(1,NGLLY,NGLLZ,ispec)) vmin = sqrt(muvstore(1,NGLLY,NGLLZ,ispec)/rhostore(1,NGLLY,NGLLZ,ispec)) ! particular case of the outer core (muvstore contains 1/rho) - if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then + if (idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then r = dsqrt(xstore(1,NGLLY,NGLLZ,ispec)**2 + ystore(1,NGLLY,NGLLZ,ispec)**2 + zstore(1,NGLLY,NGLLZ,ispec)**2) call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec)) vmax = vp vmin = vp endif - if(vmin == 0.0) vmin=vmax + if (vmin == 0.0) vmin=vmax write(11,*) numpoin,vmin,vmax endif - if(.not. mask_ibool(iglobval(5))) then + if (.not. mask_ibool(iglobval(5))) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglobval(5)) = numpoin write(10,*) numpoin,sngl(xstore(1,1,NGLLZ,ispec)), & @@ -291,13 +291,13 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & vmax = sqrt((kappavstore(1,1,NGLLZ,ispec)+4.*muvstore(1,1,NGLLZ,ispec)/3.)/rhostore(1,1,NGLLZ,ispec)) vmin = sqrt(muvstore(1,1,NGLLZ,ispec)/rhostore(1,1,NGLLZ,ispec)) ! particular case of the outer core (muvstore contains 1/rho) - if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then + if (idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then r = dsqrt(xstore(1,1,NGLLZ,ispec)**2 + ystore(1,1,NGLLZ,ispec)**2 + zstore(1,1,NGLLZ,ispec)**2) call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec)) vmax = vp vmin = vp endif - if(vmin == 0.0) vmin=vmax + if (vmin == 0.0) vmin=vmax write(11,*) numpoin,vmin,vmax endif @@ -308,9 +308,9 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & endif ! face xi = xi_max - if(iboun(2,ispec)) then + if (iboun(2,ispec)) then - if(.not. mask_ibool(iglobval(2))) then + if (.not. mask_ibool(iglobval(2))) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglobval(2)) = numpoin write(10,*) numpoin,sngl(xstore(NGLLX,1,1,ispec)), & @@ -318,17 +318,17 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & vmax = sqrt((kappavstore(NGLLX,1,1,ispec)+4.*muvstore(NGLLX,1,1,ispec)/3.)/rhostore(NGLLX,1,1,ispec)) vmin = sqrt(muvstore(NGLLX,1,1,ispec)/rhostore(NGLLX,1,1,ispec)) ! particular case of the outer core (muvstore contains 1/rho) - if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then + if (idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then r = dsqrt(xstore(NGLLX,1,1,ispec)**2 + ystore(NGLLX,1,1,ispec)**2 + zstore(NGLLX,1,1,ispec)**2) call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec)) vmax = vp vmin = vp endif - if(vmin == 0.0) vmin=vmax + if (vmin == 0.0) vmin=vmax write(11,*) numpoin,vmin,vmax endif - if(.not. mask_ibool(iglobval(3))) then + if (.not. mask_ibool(iglobval(3))) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglobval(3)) = numpoin write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,1,ispec)), & @@ -336,17 +336,17 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & vmax = sqrt((kappavstore(NGLLX,NGLLY,1,ispec)+4.*muvstore(NGLLX,NGLLY,1,ispec)/3.)/rhostore(NGLLX,NGLLY,1,ispec)) vmin = sqrt(muvstore(NGLLX,NGLLY,1,ispec)/rhostore(NGLLX,NGLLY,1,ispec)) ! particular case of the outer core (muvstore contains 1/rho) - if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then + if (idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then r = dsqrt(xstore(NGLLX,NGLLY,1,ispec)**2 + ystore(NGLLX,NGLLY,1,ispec)**2 + zstore(NGLLX,NGLLY,1,ispec)**2) call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec)) vmax = vp vmin = vp endif - if(vmin == 0.0) vmin=vmax + if (vmin == 0.0) vmin=vmax write(11,*) numpoin,vmin,vmax endif - if(.not. mask_ibool(iglobval(7))) then + if (.not. mask_ibool(iglobval(7))) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglobval(7)) = numpoin write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec)), & @@ -354,17 +354,17 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & vmax = sqrt((kappavstore(NGLLX,NGLLY,NGLLZ,ispec)+4.*muvstore(NGLLX,NGLLY,NGLLZ,ispec)/3.)/rhostore(NGLLX,NGLLY,NGLLZ,ispec)) vmin = sqrt(muvstore(NGLLX,NGLLY,NGLLZ,ispec)/rhostore(NGLLX,NGLLY,NGLLZ,ispec)) ! particular case of the outer core (muvstore contains 1/rho) - if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then + if (idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then r = dsqrt(xstore(NGLLX,NGLLY,NGLLZ,ispec)**2 + ystore(NGLLX,NGLLY,NGLLZ,ispec)**2 + zstore(NGLLX,NGLLY,NGLLZ,ispec)**2) call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec)) vmax = vp vmin = vp endif - if(vmin == 0.0) vmin=vmax + if (vmin == 0.0) vmin=vmax write(11,*) numpoin,vmin,vmax endif - if(.not. mask_ibool(iglobval(6))) then + if (.not. mask_ibool(iglobval(6))) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglobval(6)) = numpoin write(10,*) numpoin,sngl(xstore(NGLLX,1,NGLLZ,ispec)), & @@ -372,13 +372,13 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & vmax = sqrt((kappavstore(NGLLX,1,NGLLZ,ispec)+4.*muvstore(NGLLX,1,NGLLZ,ispec)/3.)/rhostore(NGLLX,1,NGLLZ,ispec)) vmin = sqrt(muvstore(NGLLX,1,NGLLZ,ispec)/rhostore(NGLLX,1,NGLLZ,ispec)) ! particular case of the outer core (muvstore contains 1/rho) - if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then + if (idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then r = dsqrt(xstore(NGLLX,1,NGLLZ,ispec)**2 + ystore(NGLLX,1,NGLLZ,ispec)**2 + zstore(NGLLX,1,NGLLZ,ispec)**2) call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec)) vmax = vp vmin = vp endif - if(vmin == 0.0) vmin=vmax + if (vmin == 0.0) vmin=vmax write(11,*) numpoin,vmin,vmax endif @@ -389,9 +389,9 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & endif ! face eta = eta_min - if(iboun(3,ispec)) then + if (iboun(3,ispec)) then - if(.not. mask_ibool(iglobval(1))) then + if (.not. mask_ibool(iglobval(1))) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglobval(1)) = numpoin write(10,*) numpoin,sngl(xstore(1,1,1,ispec)), & @@ -399,17 +399,17 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & vmax = sqrt((kappavstore(1,1,1,ispec)+4.*muvstore(1,1,1,ispec)/3.)/rhostore(1,1,1,ispec)) vmin = sqrt(muvstore(1,1,1,ispec)/rhostore(1,1,1,ispec)) ! particular case of the outer core (muvstore contains 1/rho) - if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then + if (idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then r = dsqrt(xstore(1,1,1,ispec)**2 + ystore(1,1,1,ispec)**2 + zstore(1,1,1,ispec)**2) call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec)) vmax = vp vmin = vp endif - if(vmin == 0.0) vmin=vmax + if (vmin == 0.0) vmin=vmax write(11,*) numpoin,vmin,vmax endif - if(.not. mask_ibool(iglobval(2))) then + if (.not. mask_ibool(iglobval(2))) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglobval(2)) = numpoin write(10,*) numpoin,sngl(xstore(NGLLX,1,1,ispec)), & @@ -417,17 +417,17 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & vmax = sqrt((kappavstore(NGLLX,1,1,ispec)+4.*muvstore(NGLLX,1,1,ispec)/3.)/rhostore(NGLLX,1,1,ispec)) vmin = sqrt(muvstore(NGLLX,1,1,ispec)/rhostore(NGLLX,1,1,ispec)) ! particular case of the outer core (muvstore contains 1/rho) - if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then + if (idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then r = dsqrt(xstore(NGLLX,1,1,ispec)**2 + ystore(NGLLX,1,1,ispec)**2 + zstore(NGLLX,1,1,ispec)**2) call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec)) vmax = vp vmin = vp endif - if(vmin == 0.0) vmin=vmax + if (vmin == 0.0) vmin=vmax write(11,*) numpoin,vmin,vmax endif - if(.not. mask_ibool(iglobval(6))) then + if (.not. mask_ibool(iglobval(6))) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglobval(6)) = numpoin write(10,*) numpoin,sngl(xstore(NGLLX,1,NGLLZ,ispec)), & @@ -435,17 +435,17 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & vmax = sqrt((kappavstore(NGLLX,1,NGLLZ,ispec)+4.*muvstore(NGLLX,1,NGLLZ,ispec)/3.)/rhostore(NGLLX,1,NGLLZ,ispec)) vmin = sqrt(muvstore(NGLLX,1,NGLLZ,ispec)/rhostore(NGLLX,1,NGLLZ,ispec)) ! particular case of the outer core (muvstore contains 1/rho) - if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then + if (idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then r = dsqrt(xstore(NGLLX,1,NGLLZ,ispec)**2 + ystore(NGLLX,1,NGLLZ,ispec)**2 + zstore(NGLLX,1,NGLLZ,ispec)**2) call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec)) vmax = vp vmin = vp endif - if(vmin == 0.0) vmin=vmax + if (vmin == 0.0) vmin=vmax write(11,*) numpoin,vmin,vmax endif - if(.not. mask_ibool(iglobval(5))) then + if (.not. mask_ibool(iglobval(5))) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglobval(5)) = numpoin write(10,*) numpoin,sngl(xstore(1,1,NGLLZ,ispec)), & @@ -453,13 +453,13 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & vmax = sqrt((kappavstore(1,1,NGLLZ,ispec)+4.*muvstore(1,1,NGLLZ,ispec)/3.)/rhostore(1,1,NGLLZ,ispec)) vmin = sqrt(muvstore(1,1,NGLLZ,ispec)/rhostore(1,1,NGLLZ,ispec)) ! particular case of the outer core (muvstore contains 1/rho) - if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then + if (idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then r = dsqrt(xstore(1,1,NGLLZ,ispec)**2 + ystore(1,1,NGLLZ,ispec)**2 + zstore(1,1,NGLLZ,ispec)**2) call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec)) vmax = vp vmin = vp endif - if(vmin == 0.0) vmin=vmax + if (vmin == 0.0) vmin=vmax write(11,*) numpoin,vmin,vmax endif @@ -470,9 +470,9 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & endif ! face eta = eta_max - if(iboun(4,ispec)) then + if (iboun(4,ispec)) then - if(.not. mask_ibool(iglobval(4))) then + if (.not. mask_ibool(iglobval(4))) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglobval(4)) = numpoin write(10,*) numpoin,sngl(xstore(1,NGLLY,1,ispec)), & @@ -480,17 +480,17 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & vmax = sqrt((kappavstore(1,NGLLY,1,ispec)+4.*muvstore(1,NGLLY,1,ispec)/3.)/rhostore(1,NGLLY,1,ispec)) vmin = sqrt(muvstore(1,NGLLY,1,ispec)/rhostore(1,NGLLY,1,ispec)) ! particular case of the outer core (muvstore contains 1/rho) - if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then + if (idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then r = dsqrt(xstore(1,NGLLY,1,ispec)**2 + ystore(1,NGLLY,1,ispec)**2 + zstore(1,NGLLY,1,ispec)**2) call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec)) vmax = vp vmin = vp endif - if(vmin == 0.0) vmin=vmax + if (vmin == 0.0) vmin=vmax write(11,*) numpoin,vmin,vmax endif - if(.not. mask_ibool(iglobval(3))) then + if (.not. mask_ibool(iglobval(3))) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglobval(3)) = numpoin write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,1,ispec)), & @@ -498,17 +498,17 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & vmax = sqrt((kappavstore(NGLLX,NGLLY,1,ispec)+4.*muvstore(NGLLX,NGLLY,1,ispec)/3.)/rhostore(NGLLX,NGLLY,1,ispec)) vmin = sqrt(muvstore(NGLLX,NGLLY,1,ispec)/rhostore(NGLLX,NGLLY,1,ispec)) ! particular case of the outer core (muvstore contains 1/rho) - if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then + if (idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then r = dsqrt(xstore(NGLLX,NGLLY,1,ispec)**2 + ystore(NGLLX,NGLLY,1,ispec)**2 + zstore(NGLLX,NGLLY,1,ispec)**2) call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec)) vmax = vp vmin = vp endif - if(vmin == 0.0) vmin=vmax + if (vmin == 0.0) vmin=vmax write(11,*) numpoin,vmin,vmax endif - if(.not. mask_ibool(iglobval(7))) then + if (.not. mask_ibool(iglobval(7))) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglobval(7)) = numpoin write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec)), & @@ -516,17 +516,17 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & vmax = sqrt((kappavstore(NGLLX,NGLLY,NGLLZ,ispec)+4.*muvstore(NGLLX,NGLLY,NGLLZ,ispec)/3.)/rhostore(NGLLX,NGLLY,NGLLZ,ispec)) vmin = sqrt(muvstore(NGLLX,NGLLY,NGLLZ,ispec)/rhostore(NGLLX,NGLLY,NGLLZ,ispec)) ! particular case of the outer core (muvstore contains 1/rho) - if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then + if (idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then r = dsqrt(xstore(NGLLX,NGLLY,NGLLZ,ispec)**2 + ystore(NGLLX,NGLLY,NGLLZ,ispec)**2 + zstore(NGLLX,NGLLY,NGLLZ,ispec)**2) call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec)) vmax = vp vmin = vp endif - if(vmin == 0.0) vmin=vmax + if (vmin == 0.0) vmin=vmax write(11,*) numpoin,vmin,vmax endif - if(.not. mask_ibool(iglobval(8))) then + if (.not. mask_ibool(iglobval(8))) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglobval(8)) = numpoin write(10,*) numpoin,sngl(xstore(1,NGLLY,NGLLZ,ispec)), & @@ -534,13 +534,13 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & vmax = sqrt((kappavstore(1,NGLLY,NGLLZ,ispec)+4.*muvstore(1,NGLLY,NGLLZ,ispec)/3.)/rhostore(1,NGLLY,NGLLZ,ispec)) vmin = sqrt(muvstore(1,NGLLY,NGLLZ,ispec)/rhostore(1,NGLLY,NGLLZ,ispec)) ! particular case of the outer core (muvstore contains 1/rho) - if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then + if (idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then r = dsqrt(xstore(1,NGLLY,NGLLZ,ispec)**2 + ystore(1,NGLLY,NGLLZ,ispec)**2 + zstore(1,NGLLY,NGLLZ,ispec)**2) call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec)) vmax = vp vmin = vp endif - if(vmin == 0.0) vmin=vmax + if (vmin == 0.0) vmin=vmax write(11,*) numpoin,vmin,vmax endif @@ -554,7 +554,7 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & enddo ! check that number of global points output is okay - if(numpoin /= npoin) & + if (numpoin /= npoin) & call exit_MPI(myrank,'incorrect number of global points in AVS or DX file creation') close(10) @@ -564,7 +564,7 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & ! writing elements open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementschunks.txt',status='unknown') - if(ISOTROPIC_3D_MANTLE) & + if (ISOTROPIC_3D_MANTLE) & open(unit=11,file=prname(1:len_trim(prname))//'AVS_DXelementschunks_dvp_dvs.txt',status='unknown') ! number of elements in AVS or DX file @@ -573,7 +573,7 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & ispecface = 0 do ispec=1,nspec ! only if on face - if(iboun(1,ispec) .or. iboun(2,ispec) .or. & + if (iboun(1,ispec) .or. iboun(2,ispec) .or. & iboun(3,ispec) .or. iboun(4,ispec)) then iglobval(1)=ibool(1,1,1,ispec) iglobval(2)=ibool(NGLLX,1,1,ispec) @@ -586,11 +586,11 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & ! include lateral variations if needed - if(ISOTROPIC_3D_MANTLE) then + if (ISOTROPIC_3D_MANTLE) then ! pick a point within the element and get its radius r=dsqrt(xstore(2,2,2,ispec)**2+ystore(2,2,2,ispec)**2+zstore(2,2,2,ispec)**2) - if(r > RCMB/R_EARTH .and. r < R_UNIT_SPHERE) then + if (r > RCMB/R_EARTH .and. r < R_UNIT_SPHERE) then ! average over the element dvp = 0.0 dvs = 0.0 @@ -604,7 +604,7 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & z=zstore(i,j,k,ispec) r=dsqrt(x*x+y*y+z*z) ! take out ellipticity - if(ELLIPTICITY) then + if (ELLIPTICITY) then call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi_dummy) cost=dcos(theta) p20=0.5d0*(3.0d0*cost*cost-1.0d0) @@ -613,30 +613,30 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & r=r/factor endif - if(REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) then + if (REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) then call model_iasp91(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec),ONE_CRUST, & .true.,RICB,RCMB,RTOPDDOUBLEPRIME,R771,R670,R400,R220,R120,RMOHO,RMIDDLE_CRUST) - else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_PREM) then + else if (REFERENCE_1D_MODEL == REFERENCE_MODEL_PREM) then call prem_iso(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec), & CRUSTAL,ONE_CRUST,.true.,RICB,RCMB,RTOPDDOUBLEPRIME, & R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN) - else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then + else if (REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then call model_1066a(r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec),M1066a_V) - else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135) then + else if (REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135) then call model_ak135(r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec),Mak135_V) - else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then + else if (REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then call model_ref(r,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu,idoubling(ispec),CRUSTAL,Mref_V) vp = vpv vs = vsv - else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_JP1D) then + else if (REFERENCE_1D_MODEL == REFERENCE_MODEL_JP1D) then call model_jp1d(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec), & .true.,RICB,RCMB,RTOPDDOUBLEPRIME, & R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST) - else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) then + else if (REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) then call model_sea1d(r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec),SEA1DM_V) else call exit_MPI(myrank,'unknown 1D reference Earth model in writing of AVS/DX data') @@ -656,50 +656,50 @@ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, & endif ! face xi = xi_min - if(iboun(1,ispec)) then + if (iboun(1,ispec)) then ispecface = ispecface + 1 write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglobval(1)), & num_ibool_AVS_DX(iglobval(4)),num_ibool_AVS_DX(iglobval(8)), & num_ibool_AVS_DX(iglobval(5)) - if(ISOTROPIC_3D_MANTLE) write(11,*) ispecface,dvp,dvs + if (ISOTROPIC_3D_MANTLE) write(11,*) ispecface,dvp,dvs endif ! face xi = xi_max - if(iboun(2,ispec)) then + if (iboun(2,ispec)) then ispecface = ispecface + 1 write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglobval(2)), & num_ibool_AVS_DX(iglobval(3)),num_ibool_AVS_DX(iglobval(7)), & num_ibool_AVS_DX(iglobval(6)) - if(ISOTROPIC_3D_MANTLE) write(11,*) ispecface,dvp,dvs + if (ISOTROPIC_3D_MANTLE) write(11,*) ispecface,dvp,dvs endif ! face eta = eta_min - if(iboun(3,ispec)) then + if (iboun(3,ispec)) then ispecface = ispecface + 1 write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglobval(1)), & num_ibool_AVS_DX(iglobval(2)),num_ibool_AVS_DX(iglobval(6)), & num_ibool_AVS_DX(iglobval(5)) - if(ISOTROPIC_3D_MANTLE) write(11,*) ispecface,dvp,dvs + if (ISOTROPIC_3D_MANTLE) write(11,*) ispecface,dvp,dvs endif ! face eta = eta_max - if(iboun(4,ispec)) then + if (iboun(4,ispec)) then ispecface = ispecface + 1 write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglobval(4)), & num_ibool_AVS_DX(iglobval(3)),num_ibool_AVS_DX(iglobval(7)), & num_ibool_AVS_DX(iglobval(8)) - if(ISOTROPIC_3D_MANTLE) write(11,*) ispecface,dvp,dvs + if (ISOTROPIC_3D_MANTLE) write(11,*) ispecface,dvp,dvs endif endif enddo ! check that number of surface elements output is okay - if(ispecface /= nspecface) & + if (ispecface /= nspecface) & call exit_MPI(myrank,'incorrect number of surface elements in AVS or DX file creation') close(10) - if(ISOTROPIC_3D_MANTLE) close(11) + if (ISOTROPIC_3D_MANTLE) close(11) end subroutine write_AVS_DX_global_chunks_data diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/write_AVS_DX_global_data.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/write_AVS_DX_global_data.f90 index 877d89588..a66587247 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/write_AVS_DX_global_data.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/write_AVS_DX_global_data.f90 @@ -102,49 +102,49 @@ subroutine write_AVS_DX_global_data(myrank,prname,nspec,ibool,idoubling, & iglob6=ibool(NGLLX,1,NGLLZ,ispec) iglob7=ibool(NGLLX,NGLLY,NGLLZ,ispec) iglob8=ibool(1,NGLLY,NGLLZ,ispec) - if(.not. mask_ibool(iglob1)) then + if (.not. mask_ibool(iglob1)) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglob1) = numpoin write(10,*) numpoin,sngl(xstore(1,1,1,ispec)), & sngl(ystore(1,1,1,ispec)),sngl(zstore(1,1,1,ispec)) endif - if(.not. mask_ibool(iglob2)) then + if (.not. mask_ibool(iglob2)) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglob2) = numpoin write(10,*) numpoin,sngl(xstore(NGLLX,1,1,ispec)), & sngl(ystore(NGLLX,1,1,ispec)),sngl(zstore(NGLLX,1,1,ispec)) endif - if(.not. mask_ibool(iglob3)) then + if (.not. mask_ibool(iglob3)) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglob3) = numpoin write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,1,ispec)), & sngl(ystore(NGLLX,NGLLY,1,ispec)),sngl(zstore(NGLLX,NGLLY,1,ispec)) endif - if(.not. mask_ibool(iglob4)) then + if (.not. mask_ibool(iglob4)) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglob4) = numpoin write(10,*) numpoin,sngl(xstore(1,NGLLY,1,ispec)), & sngl(ystore(1,NGLLY,1,ispec)),sngl(zstore(1,NGLLY,1,ispec)) endif - if(.not. mask_ibool(iglob5)) then + if (.not. mask_ibool(iglob5)) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglob5) = numpoin write(10,*) numpoin,sngl(xstore(1,1,NGLLZ,ispec)), & sngl(ystore(1,1,NGLLZ,ispec)),sngl(zstore(1,1,NGLLZ,ispec)) endif - if(.not. mask_ibool(iglob6)) then + if (.not. mask_ibool(iglob6)) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglob6) = numpoin write(10,*) numpoin,sngl(xstore(NGLLX,1,NGLLZ,ispec)), & sngl(ystore(NGLLX,1,NGLLZ,ispec)),sngl(zstore(NGLLX,1,NGLLZ,ispec)) endif - if(.not. mask_ibool(iglob7)) then + if (.not. mask_ibool(iglob7)) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglob7) = numpoin write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec)), & sngl(ystore(NGLLX,NGLLY,NGLLZ,ispec)),sngl(zstore(NGLLX,NGLLY,NGLLZ,ispec)) endif - if(.not. mask_ibool(iglob8)) then + if (.not. mask_ibool(iglob8)) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglob8) = numpoin write(10,*) numpoin,sngl(xstore(1,NGLLY,NGLLZ,ispec)), & @@ -161,7 +161,7 @@ subroutine write_AVS_DX_global_data(myrank,prname,nspec,ibool,idoubling, & enddo ! check that number of global points output is okay - if(numpoin /= npoin) & + if (numpoin /= npoin) & call exit_MPI(myrank,'incorrect number of global points in AVS or DX file creation') close(10) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/write_AVS_DX_global_faces_data.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/write_AVS_DX_global_faces_data.f90 index a1c7bb327..323430d1c 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/write_AVS_DX_global_faces_data.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/write_AVS_DX_global_faces_data.f90 @@ -73,7 +73,7 @@ subroutine write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut ! mark global AVS or DX points do ispec=1,nspec ! only if on face - if(iMPIcut_xi(1,ispec) .or. iMPIcut_xi(2,ispec) .or. & + if (iMPIcut_xi(1,ispec) .or. iMPIcut_xi(2,ispec) .or. & iMPIcut_eta(1,ispec) .or. iMPIcut_eta(2,ispec)) then iglob1=ibool(1,1,1,ispec) iglob2=ibool(NGLLX,1,1,ispec) @@ -85,7 +85,7 @@ subroutine write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut iglob8=ibool(1,NGLLY,NGLLZ,ispec) ! face xi = xi_min - if(iMPIcut_xi(1,ispec)) then + if (iMPIcut_xi(1,ispec)) then nspecface = nspecface + 1 mask_ibool(iglob1) = .true. mask_ibool(iglob4) = .true. @@ -94,7 +94,7 @@ subroutine write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut endif ! face xi = xi_max - if(iMPIcut_xi(2,ispec)) then + if (iMPIcut_xi(2,ispec)) then nspecface = nspecface + 1 mask_ibool(iglob2) = .true. mask_ibool(iglob3) = .true. @@ -103,7 +103,7 @@ subroutine write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut endif ! face eta = eta_min - if(iMPIcut_eta(1,ispec)) then + if (iMPIcut_eta(1,ispec)) then nspecface = nspecface + 1 mask_ibool(iglob1) = .true. mask_ibool(iglob2) = .true. @@ -112,7 +112,7 @@ subroutine write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut endif ! face eta = eta_max - if(iMPIcut_eta(2,ispec)) then + if (iMPIcut_eta(2,ispec)) then nspecface = nspecface + 1 mask_ibool(iglob4) = .true. mask_ibool(iglob3) = .true. @@ -136,7 +136,7 @@ subroutine write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut numpoin = 0 do ispec=1,nspec ! only if on face - if(iMPIcut_xi(1,ispec) .or. iMPIcut_xi(2,ispec) .or. & + if (iMPIcut_xi(1,ispec) .or. iMPIcut_xi(2,ispec) .or. & iMPIcut_eta(1,ispec) .or. iMPIcut_eta(2,ispec)) then iglob1=ibool(1,1,1,ispec) iglob2=ibool(NGLLX,1,1,ispec) @@ -148,26 +148,26 @@ subroutine write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut iglob8=ibool(1,NGLLY,NGLLZ,ispec) ! face xi = xi_min - if(iMPIcut_xi(1,ispec)) then - if(.not. mask_ibool(iglob1)) then + if (iMPIcut_xi(1,ispec)) then + if (.not. mask_ibool(iglob1)) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglob1) = numpoin write(10,*) numpoin,sngl(xstore(1,1,1,ispec)), & sngl(ystore(1,1,1,ispec)),sngl(zstore(1,1,1,ispec)) endif - if(.not. mask_ibool(iglob4)) then + if (.not. mask_ibool(iglob4)) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglob4) = numpoin write(10,*) numpoin,sngl(xstore(1,NGLLY,1,ispec)), & sngl(ystore(1,NGLLY,1,ispec)),sngl(zstore(1,NGLLY,1,ispec)) endif - if(.not. mask_ibool(iglob8)) then + if (.not. mask_ibool(iglob8)) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglob8) = numpoin write(10,*) numpoin,sngl(xstore(1,NGLLY,NGLLZ,ispec)), & sngl(ystore(1,NGLLY,NGLLZ,ispec)),sngl(zstore(1,NGLLY,NGLLZ,ispec)) endif - if(.not. mask_ibool(iglob5)) then + if (.not. mask_ibool(iglob5)) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglob5) = numpoin write(10,*) numpoin,sngl(xstore(1,1,NGLLZ,ispec)), & @@ -180,26 +180,26 @@ subroutine write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut endif ! face xi = xi_max - if(iMPIcut_xi(2,ispec)) then - if(.not. mask_ibool(iglob2)) then + if (iMPIcut_xi(2,ispec)) then + if (.not. mask_ibool(iglob2)) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglob2) = numpoin write(10,*) numpoin,sngl(xstore(NGLLX,1,1,ispec)), & sngl(ystore(NGLLX,1,1,ispec)),sngl(zstore(NGLLX,1,1,ispec)) endif - if(.not. mask_ibool(iglob3)) then + if (.not. mask_ibool(iglob3)) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglob3) = numpoin write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,1,ispec)), & sngl(ystore(NGLLX,NGLLY,1,ispec)),sngl(zstore(NGLLX,NGLLY,1,ispec)) endif - if(.not. mask_ibool(iglob7)) then + if (.not. mask_ibool(iglob7)) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglob7) = numpoin write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec)), & sngl(ystore(NGLLX,NGLLY,NGLLZ,ispec)),sngl(zstore(NGLLX,NGLLY,NGLLZ,ispec)) endif - if(.not. mask_ibool(iglob6)) then + if (.not. mask_ibool(iglob6)) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglob6) = numpoin write(10,*) numpoin,sngl(xstore(NGLLX,1,NGLLZ,ispec)), & @@ -212,26 +212,26 @@ subroutine write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut endif ! face eta = eta_min - if(iMPIcut_eta(1,ispec)) then - if(.not. mask_ibool(iglob1)) then + if (iMPIcut_eta(1,ispec)) then + if (.not. mask_ibool(iglob1)) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglob1) = numpoin write(10,*) numpoin,sngl(xstore(1,1,1,ispec)), & sngl(ystore(1,1,1,ispec)),sngl(zstore(1,1,1,ispec)) endif - if(.not. mask_ibool(iglob2)) then + if (.not. mask_ibool(iglob2)) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglob2) = numpoin write(10,*) numpoin,sngl(xstore(NGLLX,1,1,ispec)), & sngl(ystore(NGLLX,1,1,ispec)),sngl(zstore(NGLLX,1,1,ispec)) endif - if(.not. mask_ibool(iglob6)) then + if (.not. mask_ibool(iglob6)) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglob6) = numpoin write(10,*) numpoin,sngl(xstore(NGLLX,1,NGLLZ,ispec)), & sngl(ystore(NGLLX,1,NGLLZ,ispec)),sngl(zstore(NGLLX,1,NGLLZ,ispec)) endif - if(.not. mask_ibool(iglob5)) then + if (.not. mask_ibool(iglob5)) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglob5) = numpoin write(10,*) numpoin,sngl(xstore(1,1,NGLLZ,ispec)), & @@ -244,26 +244,26 @@ subroutine write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut endif ! face eta = eta_max - if(iMPIcut_eta(2,ispec)) then - if(.not. mask_ibool(iglob4)) then + if (iMPIcut_eta(2,ispec)) then + if (.not. mask_ibool(iglob4)) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglob4) = numpoin write(10,*) numpoin,sngl(xstore(1,NGLLY,1,ispec)), & sngl(ystore(1,NGLLY,1,ispec)),sngl(zstore(1,NGLLY,1,ispec)) endif - if(.not. mask_ibool(iglob3)) then + if (.not. mask_ibool(iglob3)) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglob3) = numpoin write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,1,ispec)), & sngl(ystore(NGLLX,NGLLY,1,ispec)),sngl(zstore(NGLLX,NGLLY,1,ispec)) endif - if(.not. mask_ibool(iglob7)) then + if (.not. mask_ibool(iglob7)) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglob7) = numpoin write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec)), & sngl(ystore(NGLLX,NGLLY,NGLLZ,ispec)),sngl(zstore(NGLLX,NGLLY,NGLLZ,ispec)) endif - if(.not. mask_ibool(iglob8)) then + if (.not. mask_ibool(iglob8)) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglob8) = numpoin write(10,*) numpoin,sngl(xstore(1,NGLLY,NGLLZ,ispec)), & @@ -279,7 +279,7 @@ subroutine write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut enddo ! check that number of global points output is okay - if(numpoin /= npoin) & + if (numpoin /= npoin) & call exit_MPI(myrank,'incorrect number of global points in AVS or DX file creation') close(10) @@ -295,7 +295,7 @@ subroutine write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut ispecface = 0 do ispec=1,nspec ! only if on face - if(iMPIcut_xi(1,ispec) .or. iMPIcut_xi(2,ispec) .or. & + if (iMPIcut_xi(1,ispec) .or. iMPIcut_xi(2,ispec) .or. & iMPIcut_eta(1,ispec) .or. iMPIcut_eta(2,ispec)) then iglob1=ibool(1,1,1,ispec) iglob2=ibool(NGLLX,1,1,ispec) @@ -307,7 +307,7 @@ subroutine write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut iglob8=ibool(1,NGLLY,NGLLZ,ispec) ! face xi = xi_min - if(iMPIcut_xi(1,ispec)) then + if (iMPIcut_xi(1,ispec)) then ispecface = ispecface + 1 write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglob1), & num_ibool_AVS_DX(iglob4),num_ibool_AVS_DX(iglob8), & @@ -315,7 +315,7 @@ subroutine write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut endif ! face xi = xi_max - if(iMPIcut_xi(2,ispec)) then + if (iMPIcut_xi(2,ispec)) then ispecface = ispecface + 1 write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglob2), & num_ibool_AVS_DX(iglob3),num_ibool_AVS_DX(iglob7), & @@ -323,7 +323,7 @@ subroutine write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut endif ! face eta = eta_min - if(iMPIcut_eta(1,ispec)) then + if (iMPIcut_eta(1,ispec)) then ispecface = ispecface + 1 write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglob1), & num_ibool_AVS_DX(iglob2),num_ibool_AVS_DX(iglob6), & @@ -331,7 +331,7 @@ subroutine write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut endif ! face eta = eta_max - if(iMPIcut_eta(2,ispec)) then + if (iMPIcut_eta(2,ispec)) then ispecface = ispecface + 1 write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglob4), & num_ibool_AVS_DX(iglob3),num_ibool_AVS_DX(iglob7), & @@ -342,7 +342,7 @@ subroutine write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut enddo ! check that number of surface elements output is okay - if(ispecface /= nspecface) & + if (ispecface /= nspecface) & call exit_MPI(myrank,'incorrect number of surface elements in AVS or DX file creation') close(10) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/write_AVS_DX_surface_data.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/write_AVS_DX_surface_data.f90 index bfb6f40e7..1a6c028a0 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/write_AVS_DX_surface_data.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/mesher_for_serial/write_AVS_DX_surface_data.f90 @@ -70,7 +70,7 @@ subroutine write_AVS_DX_surface_data(myrank,prname,nspec,iboun, & ! mark global AVS or DX points do ispec=1,nspec ! only if at the surface (top plane) - if(iboun(6,ispec)) then + if (iboun(6,ispec)) then iglobval(5)=ibool(1,1,NGLLZ,ispec) iglobval(6)=ibool(NGLLX,1,NGLLZ,ispec) @@ -100,7 +100,7 @@ subroutine write_AVS_DX_surface_data(myrank,prname,nspec,iboun, & numpoin = 0 do ispec=1,nspec ! only if at the surface - if(iboun(6,ispec)) then + if (iboun(6,ispec)) then iglobval(5)=ibool(1,1,NGLLZ,ispec) iglobval(6)=ibool(NGLLX,1,NGLLZ,ispec) @@ -108,30 +108,30 @@ subroutine write_AVS_DX_surface_data(myrank,prname,nspec,iboun, & iglobval(8)=ibool(1,NGLLY,NGLLZ,ispec) ! top face - if(iboun(6,ispec)) then + if (iboun(6,ispec)) then - if(.not. mask_ibool(iglobval(5))) then + if (.not. mask_ibool(iglobval(5))) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglobval(5)) = numpoin write(10,*) numpoin,sngl(xstore(1,1,NGLLZ,ispec)), & sngl(ystore(1,1,NGLLZ,ispec)),sngl(zstore(1,1,NGLLZ,ispec)) endif - if(.not. mask_ibool(iglobval(6))) then + if (.not. mask_ibool(iglobval(6))) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglobval(6)) = numpoin write(10,*) numpoin,sngl(xstore(NGLLX,1,NGLLZ,ispec)), & sngl(ystore(NGLLX,1,NGLLZ,ispec)),sngl(zstore(NGLLX,1,NGLLZ,ispec)) endif - if(.not. mask_ibool(iglobval(7))) then + if (.not. mask_ibool(iglobval(7))) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglobval(7)) = numpoin write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec)), & sngl(ystore(NGLLX,NGLLY,NGLLZ,ispec)),sngl(zstore(NGLLX,NGLLY,NGLLZ,ispec)) endif - if(.not. mask_ibool(iglobval(8))) then + if (.not. mask_ibool(iglobval(8))) then numpoin = numpoin + 1 num_ibool_AVS_DX(iglobval(8)) = numpoin write(10,*) numpoin,sngl(xstore(1,NGLLY,NGLLZ,ispec)), & @@ -149,7 +149,7 @@ subroutine write_AVS_DX_surface_data(myrank,prname,nspec,iboun, & enddo ! check that number of global points output is okay - if(numpoin /= npoin) & + if (numpoin /= npoin) & call exit_MPI(myrank,'incorrect number of global points in AVS or DX file creation') close(10) @@ -165,7 +165,7 @@ subroutine write_AVS_DX_surface_data(myrank,prname,nspec,iboun, & ispecface = 0 do ispec=1,nspec ! only if at the surface - if(iboun(6,ispec)) then + if (iboun(6,ispec)) then iglobval(5)=ibool(1,1,NGLLZ,ispec) iglobval(6)=ibool(NGLLX,1,NGLLZ,ispec) @@ -182,7 +182,7 @@ subroutine write_AVS_DX_surface_data(myrank,prname,nspec,iboun, & enddo ! check that number of surface elements output is okay - if(ispecface /= nspecface) & + if (ispecface /= nspecface) & call exit_MPI(myrank,'incorrect number of surface elements in AVS or DX file creation') close(10) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/older_serial_specfem3D_inlined_v03_is_the_fastest_with_function_calls.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/older_serial_specfem3D_inlined_v03_is_the_fastest_with_function_calls.f90 index f20a2b84f..e05b98040 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/older_serial_specfem3D_inlined_v03_is_the_fastest_with_function_calls.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/older_serial_specfem3D_inlined_v03_is_the_fastest_with_function_calls.f90 @@ -147,7 +147,7 @@ program serial_specfem3D print * ! make sure the source element number is an integer - if(mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...' + if (mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...' ! read the mesh from external file open(unit=IIN,file='DATABASES_FOR_SOLVER/proc000000_reg1_database.dat',status='old') @@ -215,7 +215,7 @@ program serial_specfem3D enddo enddo - if(NGLLX /= 5) stop 'this inlined version with matrix products following Deville (2002) is only valid for NGLL = 5' + if (NGLLX /= 5) stop 'this inlined version with matrix products following Deville (2002) is only valid for NGLL = 5' ! clear initial vectors before starting the time loop ! (can remain serial because done only once before entering the time loop) @@ -239,18 +239,18 @@ program serial_specfem3D ! compute maximum of norm of displacement from time to time and display it ! in order to monitor the simulation - if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) then + if (mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) then Usolidnorm = -1. do iglob = 1,NGLOB current_value = sqrt(displ(1,iglob)**2 + displ(2,iglob)**2 + displ(3,iglob)**2) - if(current_value > Usolidnorm) Usolidnorm = current_value + if (current_value > Usolidnorm) Usolidnorm = current_value enddo write(*,*) 'Time step # ',it,' out of ',NSTEP ! compute current time time = (it-1)*deltat write(*,*) 'Max norm displacement vector U in the solid (m) = ',Usolidnorm ! check stability of the code, exit if unstable - if(Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up' + if (Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up' ! count elapsed wall-clock time call date_and_time(datein,timein,zone,time_values) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_22dec2008_NGLOB.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_22dec2008_NGLOB.f90 index ed864c128..11951d5ea 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_22dec2008_NGLOB.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_22dec2008_NGLOB.f90 @@ -145,7 +145,7 @@ program serial_specfem3D print * ! make sure the source element number is an integer - if(mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...' + if (mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...' ! read the mesh from external file open(unit=IIN,file='database.dat',status='old') @@ -211,12 +211,12 @@ program serial_specfem3D ! compute maximum of norm of displacement from time to time and display it ! in order to monitor the simulation - if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then -!!!!!!!!! if(it == 2100 .or. it == 5) then + if (mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then +!!!!!!!!! if (it == 2100 .or. it == 5) then Usolidnorm = -1. do iglob = 1,NGLOB current_value = sqrt(displ(1,iglob)**2 + displ(2,iglob)**2 + displ(3,iglob)**2) - if(current_value > Usolidnorm) Usolidnorm = current_value + if (current_value > Usolidnorm) Usolidnorm = current_value enddo write(*,*) 'Time step # ',it,' out of ',NSTEP ! compute current time @@ -224,7 +224,7 @@ program serial_specfem3D write(*,*) 'Time = ',time,' seconds out of ',(NSTEP-1)*deltat,' seconds' write(*,*) 'Max norm displacement vector U in the solid (m) = ',Usolidnorm ! check stability of the code, exit if unstable - if(Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up' + if (Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up' ! count elapsed wall-clock time call date_and_time(datein,timein,zone,time_values) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_22dec2008_NSPEC.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_22dec2008_NSPEC.f90 index 4a75a3353..df0ebe181 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_22dec2008_NSPEC.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_22dec2008_NSPEC.f90 @@ -146,7 +146,7 @@ program serial_specfem3D print * ! make sure the source element number is an integer - if(mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...' + if (mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...' ! read the mesh from external file open(unit=IIN,file='database.dat',status='old') @@ -224,15 +224,15 @@ program serial_specfem3D ! compute maximum of norm of displacement from time to time and display it ! in order to monitor the simulation - if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then -!!!!!!!!! if(it == 2100 .or. it == 5) then + if (mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then +!!!!!!!!! if (it == 2100 .or. it == 5) then Usolidnorm = -1. do ispec = 1,NSPEC do k=1,NGLLZ do j=1,NGLLY do i=1,NGLLX current_value = sqrt(displ(1,i,j,k,ispec)**2 + displ(2,i,j,k,ispec)**2 + displ(3,i,j,k,ispec)**2) - if(current_value > Usolidnorm) Usolidnorm = current_value + if (current_value > Usolidnorm) Usolidnorm = current_value enddo enddo enddo @@ -243,7 +243,7 @@ program serial_specfem3D write(*,*) 'Time = ',time,' seconds out of ',(NSTEP-1)*deltat,' seconds' write(*,*) 'Max norm displacement vector U in the solid (m) = ',Usolidnorm ! check stability of the code, exit if unstable - if(Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up' + if (Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up' ! count elapsed wall-clock time call date_and_time(datein,timein,zone,time_values) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_26dec2008_inlined_v01.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_26dec2008_inlined_v01.f90 index 044c02bb2..ab1afcde6 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_26dec2008_inlined_v01.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_26dec2008_inlined_v01.f90 @@ -150,7 +150,7 @@ program serial_specfem3D print * ! make sure the source element number is an integer - if(mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...' + if (mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...' ! read the mesh from external file open(unit=IIN,file='database.dat',status='old') @@ -223,12 +223,12 @@ program serial_specfem3D ! compute maximum of norm of displacement from time to time and display it ! in order to monitor the simulation - if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then -!!!!!!!!!!!! if(it == 2100 .or. it == 5) then + if (mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then +!!!!!!!!!!!! if (it == 2100 .or. it == 5) then Usolidnorm = -1. do iglob = 1,NGLOB current_value = sqrt(displ(1,iglob)**2 + displ(2,iglob)**2 + displ(3,iglob)**2) - if(current_value > Usolidnorm) Usolidnorm = current_value + if (current_value > Usolidnorm) Usolidnorm = current_value enddo write(*,*) 'Time step # ',it,' out of ',NSTEP ! compute current time @@ -236,7 +236,7 @@ program serial_specfem3D write(*,*) 'Time = ',time,' seconds out of ',(NSTEP-1)*deltat,' seconds' write(*,*) 'Max norm displacement vector U in the solid (m) = ',Usolidnorm ! check stability of the code, exit if unstable - if(Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up' + if (Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up' ! count elapsed wall-clock time call date_and_time(datein,timein,zone,time_values) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_26dec2008_inlined_v02.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_26dec2008_inlined_v02.f90 index 6ef14e173..c36a06447 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_26dec2008_inlined_v02.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_26dec2008_inlined_v02.f90 @@ -150,7 +150,7 @@ program serial_specfem3D print * ! make sure the source element number is an integer - if(mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...' + if (mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...' ! read the mesh from external file open(unit=IIN,file='database.dat',status='old') @@ -223,12 +223,12 @@ program serial_specfem3D ! compute maximum of norm of displacement from time to time and display it ! in order to monitor the simulation - if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then -!!!!!!!!!!!! if(it == 2100 .or. it == 5) then + if (mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then +!!!!!!!!!!!! if (it == 2100 .or. it == 5) then Usolidnorm = -1. do iglob = 1,NGLOB current_value = sqrt(displ(1,iglob)**2 + displ(2,iglob)**2 + displ(3,iglob)**2) - if(current_value > Usolidnorm) Usolidnorm = current_value + if (current_value > Usolidnorm) Usolidnorm = current_value enddo write(*,*) 'Time step # ',it,' out of ',NSTEP ! compute current time @@ -236,7 +236,7 @@ program serial_specfem3D write(*,*) 'Time = ',time,' seconds out of ',(NSTEP-1)*deltat,' seconds' write(*,*) 'Max norm displacement vector U in the solid (m) = ',Usolidnorm ! check stability of the code, exit if unstable - if(Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up' + if (Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up' ! count elapsed wall-clock time call date_and_time(datein,timein,zone,time_values) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_26dec2008_inlined_v04_is_slower.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_26dec2008_inlined_v04_is_slower.f90 index 57d71d711..87700b6d6 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_26dec2008_inlined_v04_is_slower.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_26dec2008_inlined_v04_is_slower.f90 @@ -151,7 +151,7 @@ program serial_specfem3D print * ! make sure the source element number is an integer - if(mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...' + if (mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...' ! read the mesh from external file open(unit=IIN,file='database.dat',status='old') @@ -250,12 +250,12 @@ program serial_specfem3D ! compute maximum of norm of displacement from time to time and display it ! in order to monitor the simulation - if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then -!!!!!!!!!!!! if(it == 2100 .or. it == 5) then + if (mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then +!!!!!!!!!!!! if (it == 2100 .or. it == 5) then Usolidnorm = -1. do iglob = 1,NGLOB current_value = sqrt(displ(1,iglob)**2 + displ(2,iglob)**2 + displ(3,iglob)**2) - if(current_value > Usolidnorm) Usolidnorm = current_value + if (current_value > Usolidnorm) Usolidnorm = current_value enddo write(*,*) 'Time step # ',it,' out of ',NSTEP ! compute current time @@ -263,7 +263,7 @@ program serial_specfem3D write(*,*) 'Time = ',time,' seconds out of ',(NSTEP-1)*deltat,' seconds' write(*,*) 'Max norm displacement vector U in the solid (m) = ',Usolidnorm ! check stability of the code, exit if unstable - if(Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up' + if (Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up' ! count elapsed wall-clock time call date_and_time(datein,timein,zone,time_values) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_26dec2008_inlined_v05_displx_y_z_3arrays.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_26dec2008_inlined_v05_displx_y_z_3arrays.f90 index 57bc52eba..bd12b0c59 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_26dec2008_inlined_v05_displx_y_z_3arrays.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_26dec2008_inlined_v05_displx_y_z_3arrays.f90 @@ -149,7 +149,7 @@ program serial_specfem3D print * ! make sure the source element number is an integer - if(mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...' + if (mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...' ! read the mesh from external file open(unit=IIN,file='database.dat',status='old') @@ -242,13 +242,13 @@ program serial_specfem3D ! compute maximum of norm of displacement from time to time and display it ! in order to monitor the simulation - if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then -! if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) then -!!!!!!!!!!!! if(it == 2100 .or. it == 5) then + if (mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then +! if (mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) then +!!!!!!!!!!!! if (it == 2100 .or. it == 5) then Usolidnorm = -1. do iglob = 1,NGLOB current_value = sqrt(displx(iglob)**2 + disply(iglob)**2 + displz(iglob)**2) - if(current_value > Usolidnorm) Usolidnorm = current_value + if (current_value > Usolidnorm) Usolidnorm = current_value enddo write(*,*) 'Time step # ',it,' out of ',NSTEP ! compute current time @@ -256,7 +256,7 @@ program serial_specfem3D write(*,*) 'Time = ',time,' seconds out of ',(NSTEP-1)*deltat,' seconds' write(*,*) 'Max norm displacement vector U in the solid (m) = ',Usolidnorm ! check stability of the code, exit if unstable - if(Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up' + if (Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up' ! count elapsed wall-clock time call date_and_time(datein,timein,zone,time_values) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_26dec2008_inlined_v06_fac1_merged_not_faster.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_26dec2008_inlined_v06_fac1_merged_not_faster.f90 index b8ba7800f..4dd76df94 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_26dec2008_inlined_v06_fac1_merged_not_faster.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/older_slower_versions_not_so_good_do_not_use/serial_specfem3D_26dec2008_inlined_v06_fac1_merged_not_faster.f90 @@ -149,7 +149,7 @@ program serial_specfem3D print * ! make sure the source element number is an integer - if(mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...' + if (mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...' open(unit=IIN,file='matrices.dat',status='old') do j=1,NGLLY @@ -217,7 +217,7 @@ program serial_specfem3D enddo enddo - if(NGLLX /= 5) stop 'this inlined version with matrix products following Deville (2002) is only valid for NGLL = 5' + if (NGLLX /= 5) stop 'this inlined version with matrix products following Deville (2002) is only valid for NGLL = 5' ! clear initial vectors before starting the time loop ! (can remain serial because done only once before entering the time loop) @@ -241,12 +241,12 @@ program serial_specfem3D ! compute maximum of norm of displacement from time to time and display it ! in order to monitor the simulation - if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then -!!!!!!!!!!!! if(it == 2100 .or. it == 5) then + if (mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then +!!!!!!!!!!!! if (it == 2100 .or. it == 5) then Usolidnorm = -1. do iglob = 1,NGLOB current_value = sqrt(displ(1,iglob)**2 + displ(2,iglob)**2 + displ(3,iglob)**2) - if(current_value > Usolidnorm) Usolidnorm = current_value + if (current_value > Usolidnorm) Usolidnorm = current_value enddo write(*,*) 'Time step # ',it,' out of ',NSTEP ! compute current time @@ -254,7 +254,7 @@ program serial_specfem3D write(*,*) 'Time = ',time,' seconds out of ',(NSTEP-1)*deltat,' seconds' write(*,*) 'Max norm displacement vector U in the solid (m) = ',Usolidnorm ! check stability of the code, exit if unstable - if(Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up' + if (Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up' ! count elapsed wall-clock time call date_and_time(datein,timein,zone,time_values) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/specfem3D_fastest_version_with_Deville_and_inlining.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/specfem3D_fastest_version_with_Deville_and_inlining.f90 index 514e80b7c..1f27eb7f9 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/specfem3D_fastest_version_with_Deville_and_inlining.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/specfem3D_fastest_version_with_Deville_and_inlining.f90 @@ -192,7 +192,7 @@ program serial_specfem3D print * ! make sure the source element number is an integer - if(mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...' + if (mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...' ! read the mesh from external file call read_arrays_solver(xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, & @@ -224,7 +224,7 @@ program serial_specfem3D enddo enddo - if(NGLLX /= 5) stop 'this inlined version with matrix products following Deville (2002) is only valid for NGLL = 5' + if (NGLLX /= 5) stop 'this inlined version with matrix products following Deville (2002) is only valid for NGLL = 5' !! DK DK original source and receiver to use ! ix_source = 2 @@ -254,7 +254,7 @@ program serial_specfem3D dist = dsqrt((x_target_source-xstore(i,j,k,ispec))**2 & + (y_target_source-ystore(i,j,k,ispec))**2 & + (z_target_source-zstore(i,j,k,ispec))**2) - if(dist < distmin) then + if (dist < distmin) then distmin = dist nspec_source_to_use = ispec ix_source = i @@ -290,7 +290,7 @@ program serial_specfem3D dist = dsqrt((x_target_station-xstore(i,j,k,ispec))**2 & + (y_target_station-ystore(i,j,k,ispec))**2 & + (z_target_station-zstore(i,j,k,ispec))**2) - if(dist < distmin) then + if (dist < distmin) then distmin = dist nspec_station_to_use = ispec ix_station = i @@ -331,18 +331,18 @@ program serial_specfem3D ! compute maximum of norm of displacement from time to time and display it ! in order to monitor the simulation - if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) then + if (mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) then Usolidnorm = -1. do iglob = 1,NGLOB current_value = sqrt(displ(1,iglob)**2 + displ(2,iglob)**2 + displ(3,iglob)**2) - if(current_value > Usolidnorm) Usolidnorm = current_value + if (current_value > Usolidnorm) Usolidnorm = current_value enddo write(*,*) 'Time step # ',it,' out of ',NSTEP ! compute current time time = (it-1)*deltat write(*,*) 'Max norm displacement vector U in the solid (m) = ',Usolidnorm ! check stability of the code, exit if unstable - if(Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up' + if (Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up' ! count elapsed wall-clock time call date_and_time(datein,timein,zone,time_values) diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/specfem3D_how_to_consistently_average_a_gradient.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/specfem3D_how_to_consistently_average_a_gradient.f90 index 09b1305e6..5f173e156 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/specfem3D_how_to_consistently_average_a_gradient.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/specfem3D_how_to_consistently_average_a_gradient.f90 @@ -127,7 +127,7 @@ program serial_specfem3D print * print *,'minimum and maximum valence in the mesh (the minimum should always be 1):' print *,minval(rmass_fictitious_inverse),maxval(rmass_fictitious_inverse) - if(abs(minval(rmass_fictitious_inverse) - 1._CUSTOM_REAL) > 0.000001_CUSTOM_REAL) & + if (abs(minval(rmass_fictitious_inverse) - 1._CUSTOM_REAL) > 0.000001_CUSTOM_REAL) & stop 'error: the minimum valence in the mesh is not one!' print * diff --git a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/specfem3D_normal_no_Deville.f90 b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/specfem3D_normal_no_Deville.f90 index a6e8e447d..fd9238fed 100644 --- a/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/specfem3D_normal_no_Deville.f90 +++ b/utils/small_SEM_solvers_in_Fortran_and_C_without_MPI_to_learn/specfem3D_normal_no_Deville.f90 @@ -151,7 +151,7 @@ program serial_specfem3D print * ! make sure the source element number is an integer - if(mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...' + if (mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...' ! read the mesh from external file call read_arrays_solver(xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, & @@ -197,18 +197,18 @@ program serial_specfem3D ! compute maximum of norm of displacement from time to time and display it ! in order to monitor the simulation - if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) then + if (mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) then Usolidnorm = -1. do iglob = 1,NGLOB current_value = sqrt(displ(1,iglob)**2 + displ(2,iglob)**2 + displ(3,iglob)**2) - if(current_value > Usolidnorm) Usolidnorm = current_value + if (current_value > Usolidnorm) Usolidnorm = current_value enddo write(*,*) 'Time step # ',it,' out of ',NSTEP ! compute current time time = (it-1)*deltat write(*,*) 'Max norm displacement vector U in the solid (m) = ',Usolidnorm ! check stability of the code, exit if unstable - if(Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up' + if (Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up' ! count elapsed wall-clock time call date_and_time(datein,timein,zone,time_values) diff --git a/utils/unused_routines/Sieh_1857_digitized_slip_map/extract_image_info_Sieh_1978.f90 b/utils/unused_routines/Sieh_1857_digitized_slip_map/extract_image_info_Sieh_1978.f90 index 4632df953..d69793221 100644 --- a/utils/unused_routines/Sieh_1857_digitized_slip_map/extract_image_info_Sieh_1978.f90 +++ b/utils/unused_routines/Sieh_1857_digitized_slip_map/extract_image_info_Sieh_1978.f90 @@ -28,7 +28,7 @@ program extract_curve_Sieh index_imax = -1 ! detect minimum value for this column, corresponding to darkest pixel do iy=1,NY - if(image(ix,iy) < imax) then + if (image(ix,iy) < imax) then imax = image(ix,iy) index_imax = iy endif diff --git a/utils/unused_routines/ampuero_bug_Stacey_now_fixed_in_official_SVN_code/ampuero_fix_Stacey_Hughes_1987_implicit_ABC_problem_specfem3D.f90 b/utils/unused_routines/ampuero_bug_Stacey_now_fixed_in_official_SVN_code/ampuero_fix_Stacey_Hughes_1987_implicit_ABC_problem_specfem3D.f90 index b3abc93ef..c6b927d13 100644 --- a/utils/unused_routines/ampuero_bug_Stacey_now_fixed_in_official_SVN_code/ampuero_fix_Stacey_Hughes_1987_implicit_ABC_problem_specfem3D.f90 +++ b/utils/unused_routines/ampuero_bug_Stacey_now_fixed_in_official_SVN_code/ampuero_fix_Stacey_Hughes_1987_implicit_ABC_problem_specfem3D.f90 @@ -312,7 +312,7 @@ program specfem3D !jpampuero moved this section (used to be right before time loop) !jpampuero need some of these during initialization ! distinguish whether single or double precision for reals - if(CUSTOM_REAL == SIZE_REAL) then + if (CUSTOM_REAL == SIZE_REAL) then deltat = sngl(DT) else deltat = DT @@ -321,10 +321,10 @@ program specfem3D deltatsqover2 = deltat*deltat/2. ! open main output file, only written to by process 0 - if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) & + if (myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) & open(unit=IMAIN,file='OUTPUT_FILES/output_solver.txt',status='unknown') - if(myrank == 0) then + if (myrank == 0) then write(IMAIN,*) write(IMAIN,*) '**********************************************' @@ -333,7 +333,7 @@ program specfem3D write(IMAIN,*) write(IMAIN,*) - if(FIX_UNDERFLOW_PROBLEM) write(IMAIN,*) 'Fixing slow underflow trapping problem using small initial field' + if (FIX_UNDERFLOW_PROBLEM) write(IMAIN,*) 'Fixing slow underflow trapping problem using small initial field' write(IMAIN,*) write(IMAIN,*) 'There are ',sizeprocs,' MPI processes' @@ -356,7 +356,7 @@ program specfem3D write(IMAIN,*) ! write information about precision used for floating-point operations - if(CUSTOM_REAL == SIZE_REAL) then + if (CUSTOM_REAL == SIZE_REAL) then write(IMAIN,*) 'using single precision for the calculations' else write(IMAIN,*) 'using double precision for the calculations' @@ -368,10 +368,10 @@ program specfem3D endif ! check that the code is running with the requested nb of processes - if(sizeprocs /= NPROC) call exit_MPI(myrank,'wrong number of MPI processes') + if (sizeprocs /= NPROC) call exit_MPI(myrank,'wrong number of MPI processes') ! check that we have more than 0 and less than 1000 sources - if(NSOURCES < 0 .or. NSOURCES > 999) call exit_MPI(myrank,'invalid number of sources') + if (NSOURCES < 0 .or. NSOURCES > 999) call exit_MPI(myrank,'invalid number of sources') ! dynamic allocation of arrays @@ -393,7 +393,7 @@ program specfem3D open(unit=IIN,file='OUTPUT_FILES/addressing.txt',status='old') do iproc = 0,NPROC-1 read(IIN,*) iproc_read,iproc_xi,iproc_eta - if(iproc_read /= iproc) call exit_MPI(myrank,'incorrect slice number read') + if (iproc_read /= iproc) call exit_MPI(myrank,'incorrect slice number read') addressing(iproc_xi,iproc_eta) = iproc iproc_xi_slice(iproc) = iproc_xi iproc_eta_slice(iproc) = iproc_eta @@ -424,7 +424,7 @@ program specfem3D ! check that the number of points in this slice is correct - if(minval(ibool(:,:,:,:)) /= 1 .or. maxval(ibool(:,:,:,:)) /= NGLOB_AB) & + if (minval(ibool(:,:,:,:)) /= 1 .or. maxval(ibool(:,:,:,:)) /= NGLOB_AB) & call exit_MPI(myrank,'incorrect global numbering: iboolmax does not equal nglob in crust and mantle') ! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ @@ -467,9 +467,9 @@ program specfem3D LAT_MIN,LAT_MAX,LONG_MIN,LONG_MAX,Z_DEPTH_BLOCK,UTM_PROJECTION_ZONE) enddo - if(t_cmt(1) /= 0.) call exit_MPI(myrank,'t_cmt for the first source should be zero') + if (t_cmt(1) /= 0.) call exit_MPI(myrank,'t_cmt for the first source should be zero') do isource = 2,NSOURCES - if(t_cmt(isource) < 0.) call exit_MPI(myrank,'t_cmt should not be less than zero') + if (t_cmt(isource) < 0.) call exit_MPI(myrank,'t_cmt should not be less than zero') enddo endif !jpampuero @@ -477,13 +477,13 @@ program specfem3D read(IIN,*) nrec close(IIN) - if(myrank == 0) then + if (myrank == 0) then write(IMAIN,*) write(IMAIN,*) 'Total number of receivers = ',nrec write(IMAIN,*) endif - if(nrec < 1) call exit_MPI(myrank,'need at least one receiver') + if (nrec < 1) call exit_MPI(myrank,'need at least one receiver') ! allocate memory for receiver arrays allocate(islice_selected_rec(nrec)) @@ -512,7 +512,7 @@ program specfem3D ! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ - if(myrank == 0) then + if (myrank == 0) then write(IMAIN,*) '******************************************' write(IMAIN,*) 'There are ',NEX_XI,' elements along xi' write(IMAIN,*) 'There are ',NEX_ETA,' elements along eta' @@ -631,7 +631,7 @@ program specfem3D ! Stacey put back ! read arrays for Stacey conditions - if(STACEY_ABS_CONDITIONS) then + if (STACEY_ABS_CONDITIONS) then open(unit=27,file=prname(1:len_trim(prname))//'nimin.bin',status='unknown',form='unformatted') read(27) nimin close(27) @@ -680,7 +680,7 @@ program specfem3D InNucleationRegion = abs(xstore(iglob)-HypoX)<=NucleationHalfSizeX & .and. abs(zstore(iglob)-HypoZ)<=NucleationHalfSizeZ - if ( NotInRuptureRegion ) then + if ( NotInRuptureRegion ) then FaultMuS(i,k,ispec2D) = BarrierStrength FaultMuD(i,k,ispec2D) = BarrierStrength else @@ -717,11 +717,11 @@ program specfem3D do isource = 1,NSOURCES ! check that the source slice number is okay - if(islice_selected_source(isource) < 0 .or. islice_selected_source(isource) > NPROC-1) & + if (islice_selected_source(isource) < 0 .or. islice_selected_source(isource) > NPROC-1) & call exit_MPI(myrank,'something is wrong with the source slice number') ! compute source arrays in source slice - if(myrank == islice_selected_source(isource)) then + if (myrank == islice_selected_source(isource)) then call compute_arrays_source(ispec_selected_source(isource), & xi_source(isource),eta_source(isource),gamma_source(isource),sourcearray, & Mxx(isource),Myy(isource),Mzz(isource),Mxy(isource),Mxz(isource),Myz(isource), & @@ -732,7 +732,7 @@ program specfem3D enddo - if(myrank == 0) then + if (myrank == 0) then write(IMAIN,*) write(IMAIN,*) 'Total number of samples for seismograms = ',NSTEP write(IMAIN,*) @@ -746,11 +746,11 @@ program specfem3D do irec = 1,nrec ! check that the receiver slice number is okay - if(islice_selected_rec(irec) < 0 .or. islice_selected_rec(irec) > NPROC-1) & + if (islice_selected_rec(irec) < 0 .or. islice_selected_rec(irec) > NPROC-1) & call exit_MPI(myrank,'something is wrong with the receiver slice number') ! write info about that receiver - if(myrank == islice_selected_rec(irec)) then + if (myrank == islice_selected_rec(irec)) then nrec_local = nrec_local + 1 @@ -770,7 +770,7 @@ program specfem3D allocate(number_receiver_global(nrec_local)) irec_local = 0 do irec = 1,nrec - if(myrank == islice_selected_rec(irec)) then + if (myrank == islice_selected_rec(irec)) then irec_local = irec_local + 1 number_receiver_global(irec_local) = irec endif @@ -788,10 +788,10 @@ program specfem3D ! check that the sum of the number of receivers in each slice is nrec call MPI_REDUCE(nrec_local,nrec_tot_found,1,MPI_INTEGER,MPI_SUM,0, & MPI_COMM_WORLD,ier) - if(myrank == 0) then + if (myrank == 0) then write(IMAIN,*) write(IMAIN,*) 'found a total of ',nrec_tot_found,' receivers in all the slices' - if(nrec_tot_found /= nrec) then + if (nrec_tot_found /= nrec) then call exit_MPI(myrank,'problem when dispatching the receivers') else write(IMAIN,*) 'this total is okay' @@ -802,12 +802,12 @@ program specfem3D seismograms_d(:,:,:) = 0._CUSTOM_REAL seismograms_v(:,:,:) = 0._CUSTOM_REAL - if(myrank == 0) then + if (myrank == 0) then - if(NSOURCES > 1) write(IMAIN,*) 'Using ',NSOURCES,' point sources' + if (NSOURCES > 1) write(IMAIN,*) 'Using ',NSOURCES,' point sources' write(IMAIN,*) - if(ATTENUATION) then + if (ATTENUATION) then write(IMAIN,*) 'incorporating attenuation using ',N_SLS,' standard linear solids' else write(IMAIN,*) 'no attenuation' @@ -821,11 +821,11 @@ program specfem3D call MPI_BARRIER(MPI_COMM_WORLD,ier) !jpampuero ABC ==== BEGIN modification of mass matrix for ============================ -!jpampuero ABC IMPLICIT implementation of absorbing boundaries +!jpampuero ABC implicit implementation of absorbing boundaries !jpampuero ABC M --> M+dt/2*C !jpampuero ABC where C is related to the boundary term -C*v !jpampuero ABC NOTE: assumes straight edges - if(STACEY_ABS_CONDITIONS) then + if (STACEY_ABS_CONDITIONS) then ! vn=vx*nx+vy*ny+vz*nz ! tx=rho_vp(i,j,k,ispec)*vn*nx+rho_vs(i,j,k,ispec)*(vx-vn*nx) @@ -840,7 +840,7 @@ program specfem3D do ispec2D=1,nspec2D_xmin ispec=ibelm_xmin(ispec2D) ! exclude elements that are not on absorbing edges - if(nkmin_xi(1,ispec2D) == 0 .or. njmin(1,ispec2D) == 0) cycle + if (nkmin_xi(1,ispec2D) == 0 .or. njmin(1,ispec2D) == 0) cycle i=1 do k=nkmin_xi(1,ispec2D),NGLLZ do j=njmin(1,ispec2D),njmax(1,ispec2D) @@ -862,7 +862,7 @@ program specfem3D do ispec2D=1,nspec2D_xmax ispec=ibelm_xmax(ispec2D) ! exclude elements that are not on absorbing edges - if(nkmin_xi(2,ispec2D) == 0 .or. njmin(2,ispec2D) == 0) cycle + if (nkmin_xi(2,ispec2D) == 0 .or. njmin(2,ispec2D) == 0) cycle i=NGLLX do k=nkmin_xi(2,ispec2D),NGLLZ do j=njmin(2,ispec2D),njmax(2,ispec2D) @@ -883,7 +883,7 @@ program specfem3D do ispec2D=1,nspec2D_ymax ispec=ibelm_ymax(ispec2D) ! exclude elements that are not on absorbing edges - if(nkmin_eta(2,ispec2D) == 0 .or. nimin(2,ispec2D) == 0) cycle + if (nkmin_eta(2,ispec2D) == 0 .or. nimin(2,ispec2D) == 0) cycle j=NGLLY do k=nkmin_eta(2,ispec2D),NGLLZ do i=nimin(2,ispec2D),nimax(2,ispec2D) @@ -924,10 +924,10 @@ program specfem3D buffer_send_faces,buffer_received_faces,npoin2D_xi,npoin2D_eta, & NPROC_XI,NPROC_ETA,NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX,NPOIN2DMAX_XY) - if(myrank == 0) write(IMAIN,*) 'end assembling MPI mass matrix' + if (myrank == 0) write(IMAIN,*) 'end assembling MPI mass matrix' ! check that mass matrix is positive - if(minval(rmass) <= 0.) call exit_MPI(myrank,'negative mass matrix term') + if (minval(rmass) <= 0.) call exit_MPI(myrank,'negative mass matrix term') ! for efficiency, invert final mass matrix once and for all in each slice rmass = 1.0 / rmass @@ -935,7 +935,7 @@ program specfem3D ! if attenuation is on, shift PREM to right frequency ! rescale mu in PREM to average frequency for attenuation - if(ATTENUATION) then + if (ATTENUATION) then ! get and store PREM attenuation model do iattenuation = 1,NUM_REGIONS_ATTENUATION @@ -944,7 +944,7 @@ program specfem3D tau_sigma_dble,beta_dble,one_minus_sum_beta_dble,factor_scale_dble) ! distinguish whether single or double precision for reals - if(CUSTOM_REAL == SIZE_REAL) then + if (CUSTOM_REAL == SIZE_REAL) then tau_mu(iattenuation,:) = sngl(tau_mu_dble(:)) tau_sigma(iattenuation,:) = sngl(tau_sigma_dble(:)) beta(iattenuation,:) = sngl(beta_dble(:)) @@ -980,17 +980,17 @@ program specfem3D accel(:,:) = 0._CUSTOM_REAL ! put negligible initial value to avoid very slow underflow trapping - if(FIX_UNDERFLOW_PROBLEM) displ(:,:) = VERYSMALLVAL + if (FIX_UNDERFLOW_PROBLEM) displ(:,:) = VERYSMALLVAL ! synchronize all processes to make sure everybody is ready to start time loop call MPI_BARRIER(MPI_COMM_WORLD,ier) - if(myrank == 0) write(IMAIN,*) 'All processes are synchronized before time loop' + if (myrank == 0) write(IMAIN,*) 'All processes are synchronized before time loop' ! ! s t a r t t i m e i t e r a t i o n s ! - if(myrank == 0) then + if (myrank == 0) then write(IMAIN,*) write(IMAIN,*) ' time step: ',sngl(DT),' s' write(IMAIN,*) 'number of time steps: ',NSTEP @@ -999,7 +999,7 @@ program specfem3D endif ! precompute Runge-Kutta coefficients if attenuation - if(ATTENUATION) then + if (ATTENUATION) then tauinv(:,:) = - 1. / tau_sigma(:,:) factor_common(:,:) = 2. * beta(:,:) * tauinv(:,:) alphaval(:,:) = 1 + deltat*tauinv(:,:) + deltat**2*tauinv(:,:)**2 / 2. + & @@ -1008,14 +1008,14 @@ program specfem3D gammaval(:,:) = deltat / 2. + deltat**2*tauinv(:,:) / 6. + deltat**3*tauinv(:,:)**2 / 24. endif - if(myrank == 0) then + if (myrank == 0) then write(IMAIN,*) write(IMAIN,*) 'Starting time iteration loop...' write(IMAIN,*) endif ! create an empty file to monitor the start of the simulation - if(myrank == 0) then + if (myrank == 0) then open(unit=IOUT,file='OUTPUT_FILES/starttimeloop.txt',status='unknown') write(IOUT,*) 'starting time loop' close(IOUT) @@ -1025,14 +1025,14 @@ program specfem3D time_start = MPI_WTIME() ! clear memory variables if attenuation - if(ATTENUATION) then + if (ATTENUATION) then R_xx(:,:,:,:,:) = 0._CUSTOM_REAL R_yy(:,:,:,:,:) = 0._CUSTOM_REAL R_xy(:,:,:,:,:) = 0._CUSTOM_REAL R_xz(:,:,:,:,:) = 0._CUSTOM_REAL R_yz(:,:,:,:,:) = 0._CUSTOM_REAL - if(FIX_UNDERFLOW_PROBLEM) then + if (FIX_UNDERFLOW_PROBLEM) then R_xx(:,:,:,:,:) = VERYSMALLVAL R_yy(:,:,:,:,:) = VERYSMALLVAL R_xy(:,:,:,:,:) = VERYSMALLVAL @@ -1051,7 +1051,7 @@ program specfem3D ! compute the maximum of the norm of the displacement ! in all the slices using an MPI reduction ! and output timestamp file to check that simulation is running fine - if(mod(it,ITAFF_TIME_STEPS) == 0 .or. it == 5) then + if (mod(it,ITAFF_TIME_STEPS) == 0 .or. it == 5) then ! compute maximum of norm of displacement in each slice Usolidnorm = sqrt(maxval(displ(1,:)**2 + displ(2,:)**2 + displ(3,:)**2)) @@ -1060,7 +1060,7 @@ program specfem3D call MPI_REDUCE(Usolidnorm,Usolidnorm_all,1,CUSTOM_MPI_TYPE,MPI_MAX,0, & MPI_COMM_WORLD,ier) - if(myrank == 0) then + if (myrank == 0) then write(IMAIN,*) 'Time step # ',it write(IMAIN,*) 'Time: ',sngl((it-1)*DT-hdur(1)),' seconds' @@ -1089,7 +1089,7 @@ program specfem3D close(IOUT) ! check stability of the code, exit if unstable - if(Usolidnorm_all > STABILITY_THRESHOLD) call exit_MPI(myrank,'code became unstable and blew up') + if (Usolidnorm_all > STABILITY_THRESHOLD) call exit_MPI(myrank,'code became unstable and blew up') endif endif @@ -1186,7 +1186,7 @@ program specfem3D duzdyl_plus_duydzl = duzdyl + duydzl ! precompute terms for attenuation if needed - if(ATTENUATION) then + if (ATTENUATION) then ! compute deviatoric strain epsilon_trace_over_3 = ONE_THIRD * (duxdxl + duydyl + duzdzl) @@ -1207,7 +1207,7 @@ program specfem3D mul = mustore(i,j,k,ispec) ! use unrelaxed parameters if attenuation - if(ATTENUATION) mul = mul * one_minus_sum_beta_use + if (ATTENUATION) mul = mul * one_minus_sum_beta_use lambdalplus2mul = kappal + FOUR_THIRDS * mul lambdal = lambdalplus2mul - 2.*mul @@ -1222,7 +1222,7 @@ program specfem3D sigma_yz = mul*duzdyl_plus_duydzl ! subtract memory variables if attenuation - if(ATTENUATION) then + if (ATTENUATION) then do i_sls = 1,N_SLS R_xx_val = R_xx(i,j,k,ispec,i_sls) R_yy_val = R_yy(i,j,k,ispec,i_sls) @@ -1303,7 +1303,7 @@ program specfem3D ! update memory variables based upon the Runge-Kutta scheme - if(ATTENUATION) then + if (ATTENUATION) then ! use Runge-Kutta scheme to march in time do i_sls = 1,N_SLS @@ -1351,7 +1351,7 @@ program specfem3D enddo ! save deviatoric strain for Runge-Kutta scheme - if(ATTENUATION) then + if (ATTENUATION) then epsilondev_xx(:,:,:,ispec) = epsilondev_xx_loc(:,:,:) epsilondev_yy(:,:,:,ispec) = epsilondev_yy_loc(:,:,:) epsilondev_xy(:,:,:,ispec) = epsilondev_xy_loc(:,:,:) @@ -1364,7 +1364,7 @@ program specfem3D !jpampuero *********** BEGIN ABSORBING BOUNDARY CONDITIONS ****************** ! add Stacey conditions - if(STACEY_ABS_CONDITIONS) then + if (STACEY_ABS_CONDITIONS) then ! xmin do ispec2D=1,nspec2D_xmin @@ -1372,7 +1372,7 @@ program specfem3D ispec=ibelm_xmin(ispec2D) ! exclude elements that are not on absorbing edges - if(nkmin_xi(1,ispec2D) == 0 .or. njmin(1,ispec2D) == 0) cycle + if (nkmin_xi(1,ispec2D) == 0 .or. njmin(1,ispec2D) == 0) cycle i=1 do k=nkmin_xi(1,ispec2D),NGLLZ @@ -1408,7 +1408,7 @@ program specfem3D ispec=ibelm_xmax(ispec2D) ! exclude elements that are not on absorbing edges - if(nkmin_xi(2,ispec2D) == 0 .or. njmin(2,ispec2D) == 0) cycle + if (nkmin_xi(2,ispec2D) == 0 .or. njmin(2,ispec2D) == 0) cycle i=NGLLX do k=nkmin_xi(2,ispec2D),NGLLZ @@ -1452,7 +1452,7 @@ program specfem3D do ispec2D=1,nspec2D_ymin ! exclude elements that are not on absorbing edges - if(nkmin_eta(1,ispec2D) == 0 .or. nimin(1,ispec2D) == 0) cycle + if (nkmin_eta(1,ispec2D) == 0 .or. nimin(1,ispec2D) == 0) cycle !ispec = bulk element associated to the ispec2D'th boundary element ispec=ibelm_ymin(ispec2D) @@ -1520,7 +1520,7 @@ program specfem3D enddo do ispec2D=1,nspec2D_ymin - if(nkmin_eta(1,ispec2D) == 0 .or. nimin(1,ispec2D) == 0) cycle + if (nkmin_eta(1,ispec2D) == 0 .or. nimin(1,ispec2D) == 0) cycle ispec=ibelm_ymin(ispec2D) j=1 do k=nkmin_eta(1,ispec2D),NGLLZ @@ -1545,7 +1545,7 @@ program specfem3D ispec=ibelm_ymax(ispec2D) ! exclude elements that are not on absorbing edges - if(nkmin_eta(2,ispec2D) == 0 .or. nimin(2,ispec2D) == 0) cycle + if (nkmin_eta(2,ispec2D) == 0 .or. nimin(2,ispec2D) == 0) cycle j=NGLLY do k=nkmin_eta(2,ispec2D),NGLLZ @@ -1618,12 +1618,12 @@ program specfem3D do isource = 1,NSOURCES ! add the source (only if this proc carries the source) - if(myrank == islice_selected_source(isource)) then + if (myrank == islice_selected_source(isource)) then stf = comp_source_time_function(dble(it-1)*DT-hdur(isource)-t_cmt(isource),hdur(isource)) ! distinguish whether single or double precision for reals - if(CUSTOM_REAL == SIZE_REAL) then + if (CUSTOM_REAL == SIZE_REAL) then stf_used = sngl(stf) else stf_used = stf @@ -1697,7 +1697,7 @@ program specfem3D ! store North, East and Vertical components ! distinguish whether single or double precision for reals - if(CUSTOM_REAL == SIZE_REAL) then + if (CUSTOM_REAL == SIZE_REAL) then seismograms_d(:,irec_local,it) = sngl((nu(:,1,irec)*uxd + nu(:,2,irec)*uyd + nu(:,3,irec)*uzd)) seismograms_v(:,irec_local,it) = sngl((nu(:,1,irec)*vxd + nu(:,2,irec)*vyd + nu(:,3,irec)*vzd)) else @@ -1708,7 +1708,7 @@ program specfem3D enddo ! write the current seismograms - if(mod(it,NSEIS) == 0) then + if (mod(it,NSEIS) == 0) then call write_seismograms_d(myrank,seismograms_d,number_receiver_global,station_name, & network_name,nrec,nrec_local,it,DT,NSTEP,hdur(1),LOCAL_PATH) !network_name,nrec,nrec_local,it,DT,NSTEP,hdur(1),'OUTPUT_FILES') !jpampuero @@ -1836,7 +1836,7 @@ program specfem3D !jpampuero === END OUTPUT: time series at selected fault points === ! close the main output file - if(myrank == 0) then + if (myrank == 0) then write(IMAIN,*) write(IMAIN,*) 'End of the simulation' write(IMAIN,*) diff --git a/utils/unused_routines/aniso_model.f90 b/utils/unused_routines/aniso_model.f90 index aba877056..841f17113 100644 --- a/utils/unused_routines/aniso_model.f90 +++ b/utils/unused_routines/aniso_model.f90 @@ -143,7 +143,7 @@ subroutine aniso_model(iflag_aniso,rho,vp,vs,c11,c12,c13,c14,c15,c16, & ! Es = E_s ! no anisotropic perturbation - if( iflag_aniso <= 0 ) then + if ( iflag_aniso <= 0 ) then ! zeta-independant A = aa C = cc @@ -179,7 +179,7 @@ subroutine aniso_model(iflag_aniso,rho,vp,vs,c11,c12,c13,c14,c15,c16, & endif ! perturbation model 1 - if( iflag_aniso == IANISOTROPY_MODEL1 ) then + if ( iflag_aniso == IANISOTROPY_MODEL1 ) then ! zeta-independant A = aa*(1.0_CUSTOM_REAL + FACTOR_A) C = cc*(1.0_CUSTOM_REAL + FACTOR_C) @@ -213,7 +213,7 @@ subroutine aniso_model(iflag_aniso,rho,vp,vs,c11,c12,c13,c14,c15,c16, & endif ! perturbation model 2 - if( iflag_aniso == IANISOTROPY_MODEL2 ) then + if ( iflag_aniso == IANISOTROPY_MODEL2 ) then ! zeta-independant A = aa*(1.0_CUSTOM_REAL + FACTOR_A + 0.1) C = cc*(1.0_CUSTOM_REAL + FACTOR_C + 0.1) diff --git a/utils/unused_routines/check_buffers_2D.f90 b/utils/unused_routines/check_buffers_2D.f90 index b155ac556..dc2804f12 100644 --- a/utils/unused_routines/check_buffers_2D.f90 +++ b/utils/unused_routines/check_buffers_2D.f90 @@ -137,7 +137,7 @@ program check_buffers_2D open(unit=34,file=trim(OUTPUT_FILES)//'/addressing.txt',status='old',action='read') do iproc = 0,NPROC-1 read(34,*) iproc_read,iproc_xi,iproc_eta - if(iproc_read /= iproc) stop 'incorrect slice number read' + if (iproc_read /= iproc) stop 'incorrect slice number read' addressing(iproc_xi,iproc_eta) = iproc enddo close(34) @@ -185,14 +185,14 @@ program check_buffers_2D 360 continue read(34,*) iboolright_xi(npoin2D_xi), & xright_xi(npoin2D_xi),yright_xi(npoin2D_xi),zright_xi(npoin2D_xi) - if(iboolright_xi(npoin2D_xi) > 0) then + if (iboolright_xi(npoin2D_xi) > 0) then npoin2D_xi = npoin2D_xi + 1 goto 360 endif npoin2D_xi = npoin2D_xi - 1 write(*,*) 'found ',npoin2D_xi,' points in iboolright_xi slice ',ithisproc read(34,*) npoin2D_xi_mesher - if(npoin2D_xi > NPOIN2DMAX_XMIN_XMAX .or. npoin2D_xi /= npoin2D_xi_mesher) then + if (npoin2D_xi > NPOIN2DMAX_XMIN_XMAX .or. npoin2D_xi /= npoin2D_xi_mesher) then stop 'incorrect iboolright_xi read' endif close(34) @@ -207,19 +207,19 @@ program check_buffers_2D 350 continue read(34,*) iboolleft_xi(npoin2D_xi), & xleft_xi(npoin2D_xi),yleft_xi(npoin2D_xi),zleft_xi(npoin2D_xi) - if(iboolleft_xi(npoin2D_xi) > 0) then + if (iboolleft_xi(npoin2D_xi) > 0) then npoin2D_xi = npoin2D_xi + 1 goto 350 endif npoin2D_xi = npoin2D_xi - 1 write(*,*) 'found ',npoin2D_xi,' points in iboolleft_xi slice ',iotherproc read(34,*) npoin2D_xi_mesher - if(npoin2D_xi > NPOIN2DMAX_XMIN_XMAX .or. npoin2D_xi /= npoin2D_xi_mesher) then + if (npoin2D_xi > NPOIN2DMAX_XMIN_XMAX .or. npoin2D_xi /= npoin2D_xi_mesher) then stop 'incorrect iboolleft_xi read' endif close(34) - if(npoin2D_xi_save == npoin2D_xi) then + if (npoin2D_xi_save == npoin2D_xi) then print *,'okay, same size for both buffers' else stop 'wrong buffer size' @@ -230,7 +230,7 @@ program check_buffers_2D do ipoin = 1,npoin2D_xi diff = dmax1(dabs(xleft_xi(ipoin)-xright_xi(ipoin)), & dabs(yleft_xi(ipoin)-yright_xi(ipoin)),dabs(zleft_xi(ipoin)-zright_xi(ipoin))) - if(diff > 0.0000001d0) then + if (diff > 0.0000001d0) then print *,'different: ',ipoin,iboolleft_xi(ipoin),iboolright_xi(ipoin),diff stop 'error: different' endif @@ -265,14 +265,14 @@ program check_buffers_2D 460 continue read(34,*) iboolright_eta(npoin2D_eta), & xright_eta(npoin2D_eta),yright_eta(npoin2D_eta),zright_eta(npoin2D_eta) - if(iboolright_eta(npoin2D_eta) > 0) then + if (iboolright_eta(npoin2D_eta) > 0) then npoin2D_eta = npoin2D_eta + 1 goto 460 endif npoin2D_eta = npoin2D_eta - 1 write(*,*) 'found ',npoin2D_eta,' points in iboolright_eta slice ',ithisproc read(34,*) npoin2D_eta_mesher - if(npoin2D_eta > NPOIN2DMAX_YMIN_YMAX .or. npoin2D_eta /= npoin2D_eta_mesher) then + if (npoin2D_eta > NPOIN2DMAX_YMIN_YMAX .or. npoin2D_eta /= npoin2D_eta_mesher) then stop 'incorrect iboolright_eta read' endif close(34) @@ -287,19 +287,19 @@ program check_buffers_2D 450 continue read(34,*) iboolleft_eta(npoin2D_eta), & xleft_eta(npoin2D_eta),yleft_eta(npoin2D_eta),zleft_eta(npoin2D_eta) - if(iboolleft_eta(npoin2D_eta) > 0) then + if (iboolleft_eta(npoin2D_eta) > 0) then npoin2D_eta = npoin2D_eta + 1 goto 450 endif npoin2D_eta = npoin2D_eta - 1 write(*,*) 'found ',npoin2D_eta,' points in iboolleft_eta slice ',iotherproc read(34,*) npoin2D_eta_mesher - if(npoin2D_eta > NPOIN2DMAX_YMIN_YMAX .or. npoin2D_eta /= npoin2D_eta_mesher) then + if (npoin2D_eta > NPOIN2DMAX_YMIN_YMAX .or. npoin2D_eta /= npoin2D_eta_mesher) then stop 'incorrect iboolleft_eta read' endif close(34) - if(npoin2D_eta_save == npoin2D_eta) then + if (npoin2D_eta_save == npoin2D_eta) then print *,'okay, same size for both buffers' else stop 'wrong buffer size' @@ -310,7 +310,7 @@ program check_buffers_2D do ipoin = 1,npoin2D_eta diff = dmax1(dabs(xleft_eta(ipoin)-xright_eta(ipoin)), & dabs(yleft_eta(ipoin)-yright_eta(ipoin)),dabs(zleft_eta(ipoin)-zright_eta(ipoin))) - if(diff > 0.0000001d0) then + if (diff > 0.0000001d0) then print *,'different: ',ipoin,iboolleft_eta(ipoin),iboolright_eta(ipoin),diff stop 'error: different' endif diff --git a/utils/unused_routines/compute_parameters.f90 b/utils/unused_routines/compute_parameters.f90 index cdfb3287b..6db02691f 100644 --- a/utils/unused_routines/compute_parameters.f90 +++ b/utils/unused_routines/compute_parameters.f90 @@ -67,7 +67,7 @@ subroutine compute_parameters(NER,NEX_XI,NEX_ETA,NPROC_XI,NPROC_ETA, & ! !--- case of a regular mesh ! - if(USE_REGULAR_MESH) then + if (USE_REGULAR_MESH) then ! total number of spectral elements along radius NER = NER_SEDIM diff --git a/utils/unused_routines/compute_rho_estimate.f90 b/utils/unused_routines/compute_rho_estimate.f90 index 8f2c652aa..be7a0fd17 100644 --- a/utils/unused_routines/compute_rho_estimate.f90 +++ b/utils/unused_routines/compute_rho_estimate.f90 @@ -40,8 +40,8 @@ subroutine compute_rho_estimate(rho,vp) rho = 0.33d0 * vp + 1280.d0 ! make sure density estimate is reasonable - if(rho > DENSITY_MAX) rho = DENSITY_MAX - if(rho < DENSITY_MIN) rho = DENSITY_MIN + if (rho > DENSITY_MAX) rho = DENSITY_MAX + if (rho < DENSITY_MIN) rho = DENSITY_MIN end subroutine compute_rho_estimate diff --git a/utils/unused_routines/create_movie_GMT/compute_parameters.f90 b/utils/unused_routines/create_movie_GMT/compute_parameters.f90 index 73de07c37..205e8451b 100644 --- a/utils/unused_routines/create_movie_GMT/compute_parameters.f90 +++ b/utils/unused_routines/create_movie_GMT/compute_parameters.f90 @@ -66,7 +66,7 @@ subroutine compute_parameters(NER,NEX_XI,NEX_ETA,NPROC_XI,NPROC_ETA, & ! !--- case of a regular mesh ! - if(USE_REGULAR_MESH) then + if (USE_REGULAR_MESH) then ! total number of spectral elements along radius NER = NER_SEDIM diff --git a/utils/unused_routines/create_movie_GMT/convert_movie_real_to_double.f90 b/utils/unused_routines/create_movie_GMT/convert_movie_real_to_double.f90 index 1fa3cc0cb..96cfe692b 100644 --- a/utils/unused_routines/create_movie_GMT/convert_movie_real_to_double.f90 +++ b/utils/unused_routines/create_movie_GMT/convert_movie_real_to_double.f90 @@ -112,7 +112,7 @@ program convert_movie_real_to_double NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, & NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX,NGLOB_AB) - if(USE_HIGHRES_FOR_MOVIES) then + if (USE_HIGHRES_FOR_MOVIES) then ilocnum = NGLLSQUARE*NEX_PER_PROC_XI*NEX_PER_PROC_ETA else ilocnum = NGNOD2D_AVS_DX*NEX_PER_PROC_XI*NEX_PER_PROC_ETA @@ -121,12 +121,12 @@ program convert_movie_real_to_double allocate(store_val_double(ilocnum,0:NPROC-1)) print *, 'data = ', ilocnum*NPROC*8/1024/1024,' MB' - if(it1 == -1) then + if (it1 == -1) then plot_shaking_map = .true. nframes = 1 it1 = 1 inorm = it2 - if(inorm < 1 .or. inorm > 3) stop 'incorrect value of inorm' + if (inorm < 1 .or. inorm > 3) stop 'incorrect value of inorm' it2 = 1 else plot_shaking_map = .false. @@ -141,12 +141,12 @@ program convert_movie_real_to_double enddo print * print *,'total number of frames will be ',nframes - if(nframes == 0) stop 'null number of frames' + if (nframes == 0) stop 'null number of frames' max_all_frames = -100.0 endif ! define the total number of elements at the surface - if(USE_HIGHRES_FOR_MOVIES) then + if (USE_HIGHRES_FOR_MOVIES) then nspectot_AVS_max = NEX_XI * NEX_ETA * (NGLLX-1) * (NGLLY-1) else nspectot_AVS_max = NEX_XI * NEX_ETA @@ -160,7 +160,7 @@ program convert_movie_real_to_double iframe = iframe + 1 ivalue = it * NTSTEP_BETWEEN_FRAMES print *, 'ivalue = ' ,ivalue - if(plot_shaking_map) then + if (plot_shaking_map) then print *,'reading shaking map snapshot' else print *,'reading snapshot frame ',it,' out of ',NSTEP/NTSTEP_BETWEEN_FRAMES @@ -168,7 +168,7 @@ program convert_movie_real_to_double print * ! read all the elements from the same file - if(plot_shaking_map) then + if (plot_shaking_map) then write(outputname,"('/shakingdata')") else write(outputname,"('/moviedata',i6.6)") ivalue diff --git a/utils/unused_routines/create_movie_GMT/create_movie_GMT.f90 b/utils/unused_routines/create_movie_GMT/create_movie_GMT.f90 index 3d1329034..afed41bd5 100644 --- a/utils/unused_routines/create_movie_GMT/create_movie_GMT.f90 +++ b/utils/unused_routines/create_movie_GMT/create_movie_GMT.f90 @@ -144,14 +144,14 @@ program create_movie_GMT print *, 'DT = ', DT , ' NSTEP = ', NSTEP print * - if(SAVE_DISPLACEMENT) then + if (SAVE_DISPLACEMENT) then print *,'Vertical displacement will be shown in movie' else print *,'Vertical velocity will be shown in movie' endif print * - if(USE_HIGHRES_FOR_MOVIES) then + if (USE_HIGHRES_FOR_MOVIES) then print *, 'Movie is in high-resolution' ilocnum = NGLLSQUARE*NEX_PER_PROC_XI*NEX_PER_PROC_ETA else @@ -167,12 +167,12 @@ program create_movie_GMT zscaling = 0. - if(it1 == -1) then + if (it1 == -1) then plot_shaking_map = .true. nframes = 1 it1 = 1 inorm = it2 - if(inorm < 1 .or. inorm > 3) stop 'incorrect value of inorm' + if (inorm < 1 .or. inorm > 3) stop 'incorrect value of inorm' it2 = 1 else plot_shaking_map = .false. @@ -187,13 +187,13 @@ program create_movie_GMT enddo print * print *,'total number of frames will be ',nframes - if(nframes == 0) stop 'null number of frames' + if (nframes == 0) stop 'null number of frames' max_all_frames = -100.0 endif ! define the total number of elements at the surface - if(USE_HIGHRES_FOR_MOVIES) then + if (USE_HIGHRES_FOR_MOVIES) then nspectot_AVS_max = NEX_XI * NEX_ETA * (NGLLX-1) * (NGLLY-1) else nspectot_AVS_max = NEX_XI * NEX_ETA @@ -217,7 +217,7 @@ program create_movie_GMT ! -------------------------------------- - if(USE_HIGHRES_FOR_MOVIES) then + if (USE_HIGHRES_FOR_MOVIES) then allocate(x(NGLLX,NGLLY)) allocate(y(NGLLX,NGLLY)) allocate(z(NGLLX,NGLLY)) @@ -233,7 +233,7 @@ program create_movie_GMT iframe = iframe + 1 ivalue = it * NTSTEP_BETWEEN_FRAMES ! print *, 'ivalue = ' ,ivalue - if(plot_shaking_map) then + if (plot_shaking_map) then print *,'reading shaking map snapshot' else print *,'reading snapshot frame ',it,' out of ',NSTEP/NTSTEP_BETWEEN_FRAMES @@ -241,7 +241,7 @@ program create_movie_GMT print * ! read all the elements from the same file - if(plot_shaking_map) then + if (plot_shaking_map) then write(outputname,"('/shakingdata')") else write(outputname,"('/moviedata',i6.6)") ivalue @@ -282,7 +282,7 @@ program create_movie_GMT do ispecloc = 1,NEX_PER_PROC_XI*NEX_PER_PROC_ETA - if(USE_HIGHRES_FOR_MOVIES) then + if (USE_HIGHRES_FOR_MOVIES) then ! assign the OpenDX "elements" do j = 1,NGLLY @@ -305,10 +305,10 @@ program create_movie_GMT y(i,j) = ycoord z(i,j) = zcoord - if(plot_shaking_map) then - if(inorm == 1) then + if (plot_shaking_map) then + if (inorm == 1) then display(i,j) = vectorx - else if(inorm == 2) then + else if (inorm == 2) then display(i,j) = vectory else display(i,j) = vectorz @@ -329,17 +329,17 @@ program create_movie_GMT ieoff = NGNOD2D_AVS_DX*(ielm+(i-1)+(j-1)*(NGLLX-1)) do ilocnum = 1,NGNOD2D_AVS_DX - if(ilocnum == 1) then + if (ilocnum == 1) then xp(ieoff+ilocnum) = dble(x(i,j)) yp(ieoff+ilocnum) = dble(y(i,j)) zp(ieoff+ilocnum) = dble(z(i,j)) field_display(ieoff+ilocnum) = dble(display(i,j)) - else if(ilocnum == 2) then + else if (ilocnum == 2) then xp(ieoff+ilocnum) = dble(x(i+1,j)) yp(ieoff+ilocnum) = dble(y(i+1,j)) zp(ieoff+ilocnum) = dble(z(i+1,j)) field_display(ieoff+ilocnum) = dble(display(i+1,j)) - else if(ilocnum == 3) then + else if (ilocnum == 3) then xp(ieoff+ilocnum) = dble(x(i+1,j+1)) yp(ieoff+ilocnum) = dble(y(i+1,j+1)) zp(ieoff+ilocnum) = dble(z(i+1,j+1)) @@ -383,10 +383,10 @@ program create_movie_GMT ! show vertical component of displacement or velocity in the movie ! or show norm of vector if shaking map ! for shaking map, norm of U stored in ux, V in uy and A in uz - if(plot_shaking_map) then - if(inorm == 1) then + if (plot_shaking_map) then + if (inorm == 1) then field_display(ilocnum+ieoff) = dble(vectorx) - else if(inorm == 2) then + else if (inorm == 2) then field_display(ilocnum+ieoff) = dble(vectory) else field_display(ilocnum+ieoff) = dble(vectorz) @@ -432,7 +432,7 @@ program create_movie_GMT print *,'maximum amplitude in current snapshot = ',max_field_current print * - if(plot_shaking_map) then + if (plot_shaking_map) then ! normalize field to [0:1] field_display(:) = field_display(:) / max_field_current @@ -449,7 +449,7 @@ program create_movie_GMT ! create file name and open file - if(plot_shaking_map) then + if (plot_shaking_map) then write(outputname,"('/gmt_shaking_map.xyz')") open(unit=11,file=trim(output_file_prefix)//outputname,status='unknown',iostat=ios1) else @@ -468,7 +468,7 @@ program create_movie_GMT ! four points for each element do ilocnum = 1,NGNOD2D_AVS_DX ibool_number = iglob(ilocnum+ieoff) - if(.not. mask_point(ibool_number)) then + if (.not. mask_point(ibool_number)) then call utm_geo(long,lat,xp_save(ilocnum+ieoff),yp_save(ilocnum+ieoff), & UTM_PROJECTION_ZONE,IUTM2LONGLAT,SUPPRESS_UTM_PROJECTION) if (plot_shaking_map) then @@ -517,7 +517,7 @@ program create_movie_GMT deallocate(mask_point) deallocate(ireorder) - if(USE_HIGHRES_FOR_MOVIES) then + if (USE_HIGHRES_FOR_MOVIES) then deallocate(x) deallocate(y) deallocate(z) @@ -590,9 +590,9 @@ subroutine get_global_AVS(nspec,xp,yp,zp,iglob,loc,ifseg,nglob,npointot,UTM_X_MI ! sort within each segment ioff=1 do iseg=1,nseg - if(j == 1) then + if (j == 1) then call rank(xp(ioff),ind,ninseg(iseg)) - else if(j == 2) then + else if (j == 2) then call rank(yp(ioff),ind,ninseg(iseg)) else call rank(zp(ioff),ind,ninseg(iseg)) @@ -603,24 +603,24 @@ subroutine get_global_AVS(nspec,xp,yp,zp,iglob,loc,ifseg,nglob,npointot,UTM_X_MI ! check for jumps in current coordinate ! compare the coordinates of the points within a small tolerance - if(j == 1) then + if (j == 1) then do i=2,npointot - if(dabs(xp(i)-xp(i-1)) > SMALLVALTOL) ifseg(i)=.true. + if (dabs(xp(i)-xp(i-1)) > SMALLVALTOL) ifseg(i)=.true. enddo - else if(j == 2) then + else if (j == 2) then do i=2,npointot - if(dabs(yp(i)-yp(i-1)) > SMALLVALTOL) ifseg(i)=.true. + if (dabs(yp(i)-yp(i-1)) > SMALLVALTOL) ifseg(i)=.true. enddo else do i=2,npointot - if(dabs(zp(i)-zp(i-1)) > SMALLVALTOL) ifseg(i)=.true. + if (dabs(zp(i)-zp(i-1)) > SMALLVALTOL) ifseg(i)=.true. enddo endif ! count up number of different segments nseg=0 do i=1,npointot - if(ifseg(i)) then + if (ifseg(i)) then nseg=nseg+1 ninseg(nseg)=1 else @@ -632,7 +632,7 @@ subroutine get_global_AVS(nspec,xp,yp,zp,iglob,loc,ifseg,nglob,npointot,UTM_X_MI ! assign global node numbers (now sorted lexicographically) ig=0 do i=1,npointot - if(ifseg(i)) ig=ig+1 + if (ifseg(i)) ig=ig+1 iglob(loc(i))=ig enddo @@ -671,8 +671,8 @@ subroutine rank(A,IND,N) L=n/2+1 ir=n - 100 CONTINUE - IF (l>1) THEN + 100 continue + if (l>1) then l=l-1 indx=ind(l) q=a(indx) @@ -688,12 +688,12 @@ subroutine rank(A,IND,N) endif i=l j=l+l - 200 CONTINUE - IF (J <= IR) THEN - IF (J= UTM_X_MAX) stop 'horizontal dimension of UTM block incorrect' - if(UTM_Y_MIN >= UTM_Y_MAX) stop 'vertical dimension of UTM block incorrect' + if (UTM_X_MIN >= UTM_X_MAX) stop 'horizontal dimension of UTM block incorrect' + if (UTM_Y_MIN >= UTM_Y_MAX) stop 'vertical dimension of UTM block incorrect' ! set time step and radial distribution of elements ! right distribution is determined based upon maximum value of NEX @@ -114,17 +114,17 @@ subroutine read_parameter_file(par_file,LATITUDE_MIN,LATITUDE_MAX,LONGITUDE_MIN, UTM_MAX = max(UTM_Y_MAX-UTM_Y_MIN, UTM_X_MAX-UTM_X_MIN)/1000.0 ! in KM call read_value_string(MODEL, 'model.name') - if(err_occurred() /= 0) return + if (err_occurred() /= 0) return call read_value_logical(OCEANS, 'model.OCEANS') - if(err_occurred() /= 0) return + if (err_occurred() /= 0) return call read_value_logical(TOPOGRAPHY, 'model.TOPOGRAPHY') - if(err_occurred() /= 0) return + if (err_occurred() /= 0) return call read_value_logical(ATTENUATION, 'model.ATTENUATION') - if(err_occurred() /= 0) return + if (err_occurred() /= 0) return call read_value_logical(USE_OLSEN_ATTENUATION, 'model.USE_OLSEN_ATTENUATION') - if(err_occurred() /= 0) return + if (err_occurred() /= 0) return - if(dabs(DEPTH_BLOCK_KM) <= DEPTH_MOHO_SOCAL) & + if (dabs(DEPTH_BLOCK_KM) <= DEPTH_MOHO_SOCAL) & stop 'bottom of mesh must be deeper than deepest regional layer for Southern California' ! standard mesh for Southern California on Caltech cluster @@ -140,7 +140,7 @@ subroutine read_parameter_file(par_file,LATITUDE_MIN,LATITUDE_MAX,LONGITUDE_MIN, NER_MOHO_16 = 3 NER_BOTTOM_MOHO = 3 - else if(UTM_MAX/NEX_MAX >= 1.0) then + else if (UTM_MAX/NEX_MAX >= 1.0) then ! time step in seconds DT = 0.009d0 @@ -162,7 +162,7 @@ subroutine read_parameter_file(par_file,LATITUDE_MIN,LATITUDE_MAX,LONGITUDE_MIN, NER_MOHO_16 = NER_MOHO_16 * 2 NER_BOTTOM_MOHO = NER_BOTTOM_MOHO * 4 - if(MODEL == 'SoCal') then + if (MODEL == 'SoCal') then BASEMENT_MAP = .false. MOHO_MAP_LUPEI = .false. @@ -177,7 +177,7 @@ subroutine read_parameter_file(par_file,LATITUDE_MIN,LATITUDE_MAX,LONGITUDE_MIN, ANISOTROPY = .false. USE_REGULAR_MESH = .false. - else if(MODEL == 'Harvard_LA') then + else if (MODEL == 'Harvard_LA') then BASEMENT_MAP = .true. MOHO_MAP_LUPEI = .true. @@ -192,7 +192,7 @@ subroutine read_parameter_file(par_file,LATITUDE_MIN,LATITUDE_MAX,LONGITUDE_MIN, ANISOTROPY = .false. USE_REGULAR_MESH = .false. - else if(MODEL == 'Min_Chen_anisotropy') then + else if (MODEL == 'Min_Chen_anisotropy') then BASEMENT_MAP = .false. MOHO_MAP_LUPEI = .false. @@ -212,13 +212,13 @@ subroutine read_parameter_file(par_file,LATITUDE_MIN,LATITUDE_MAX,LONGITUDE_MIN, endif ! check that Poisson's ratio is positive - if(VP_VS_RATIO_GOCAD_TOP <= sqrt(2.d0) .or. VP_VS_RATIO_GOCAD_BOTTOM <= sqrt(2.d0)) & + if (VP_VS_RATIO_GOCAD_TOP <= sqrt(2.d0) .or. VP_VS_RATIO_GOCAD_BOTTOM <= sqrt(2.d0)) & stop 'wrong value of Poisson''s ratio for Gocad Vs block' call read_value_logical(ABSORBING_CONDITIONS, 'solver.ABSORBING_CONDITIONS') - if(err_occurred() /= 0) return + if (err_occurred() /= 0) return call read_value_double_precision(RECORD_LENGTH_IN_SECONDS, 'solver.RECORD_LENGTH_IN_SECONDS') - if(err_occurred() /= 0) return + if (err_occurred() /= 0) return ! compute total number of time steps, rounded to next multiple of 100 NSTEP = 100 * (int(RECORD_LENGTH_IN_SECONDS / (100.d0*DT)) + 1) @@ -228,35 +228,35 @@ subroutine read_parameter_file(par_file,LATITUDE_MIN,LATITUDE_MAX,LONGITUDE_MIN, ! there are NLINES_PER_CMTSOLUTION_SOURCE lines per source in that file call get_value_string(CMTSOLUTION, 'solver.CMTSOLUTION', 'DATA/CMTSOLUTION') open(unit=1,file=CMTSOLUTION,iostat=ios,status='old',action='read') - if(ios /= 0) stop 'error opening CMTSOLUTION file' + if (ios /= 0) stop 'error opening CMTSOLUTION file' icounter = 0 do while(ios == 0) read(1,"(a)",iostat=ios) dummystring - if(ios == 0) icounter = icounter + 1 + if (ios == 0) icounter = icounter + 1 enddo close(1) - if(mod(icounter,NLINES_PER_CMTSOLUTION_SOURCE) /= 0) & + if (mod(icounter,NLINES_PER_CMTSOLUTION_SOURCE) /= 0) & stop 'total number of lines in CMTSOLUTION file should be a multiple of NLINES_PER_CMTSOLUTION_SOURCE' NSOURCES = icounter / NLINES_PER_CMTSOLUTION_SOURCE - if(NSOURCES < 1) stop 'need at least one source in CMTSOLUTION file' + if (NSOURCES < 1) stop 'need at least one source in CMTSOLUTION file' call read_value_logical(MOVIE_SURFACE, 'solver.MOVIE_SURFACE') - if(err_occurred() /= 0) return + if (err_occurred() /= 0) return call read_value_logical(MOVIE_VOLUME, 'solver.MOVIE_VOLUME') - if(err_occurred() /= 0) return + if (err_occurred() /= 0) return call read_value_integer(NTSTEP_BETWEEN_FRAMES, 'solver.NTSTEP_BETWEEN_FRAMES') - if(err_occurred() /= 0) return + if (err_occurred() /= 0) return call read_value_logical(CREATE_SHAKEMAP, 'solver.CREATE_SHAKEMAP') - if(err_occurred() /= 0) return + if (err_occurred() /= 0) return call read_value_logical(SAVE_DISPLACEMENT, 'solver.SAVE_DISPLACEMENT') - if(err_occurred() /= 0) return + if (err_occurred() /= 0) return call read_value_logical(USE_HIGHRES_FOR_MOVIES, 'solver.USE_HIGHRES_FOR_MOVIES') - if(err_occurred() /= 0) return + if (err_occurred() /= 0) return call read_value_double_precision(HDUR_MOVIE, 'solver.HDUR_MOVIE') - if(err_occurred() /= 0) return + if (err_occurred() /= 0) return ! computes a default hdur_movie that creates nice looking movies. ! Sets HDUR_MOVIE as the minimum period the mesh can resolve for Southern California model - if(HDUR_MOVIE <=TINYVAL .and. (MODEL == 'Harvard_LA' .or. MODEL == 'SoCal')) & + if (HDUR_MOVIE <=TINYVAL .and. (MODEL == 'Harvard_LA' .or. MODEL == 'SoCal')) & HDUR_MOVIE = max(384/NEX_XI*2.4,384/NEX_ETA*2.4) ! compute the minimum value of hdur in CMTSOLUTION file @@ -283,19 +283,19 @@ subroutine read_parameter_file(par_file,LATITUDE_MIN,LATITUDE_MAX,LONGITUDE_MIN, close(1) ! one cannot use a Heaviside source for the movies -! if((MOVIE_SURFACE .or. MOVIE_VOLUME) .and. sqrt(minval_hdur**2 + HDUR_MOVIE**2) < TINYVAL) & +! if ((MOVIE_SURFACE .or. MOVIE_VOLUME) .and. sqrt(minval_hdur**2 + HDUR_MOVIE**2) < TINYVAL) & ! stop 'hdur too small for movie creation, movies do not make sense for Heaviside source' call read_value_logical(SAVE_MESH_FILES, 'mesher.SAVE_MESH_FILES') - if(err_occurred() /= 0) return + if (err_occurred() /= 0) return call read_value_string(LOCAL_PATH, 'LOCAL_PATH') - if(err_occurred() /= 0) return + if (err_occurred() /= 0) return call read_value_integer(NTSTEP_BETWEEN_OUTPUT_INFO, 'solver.NTSTEP_BETWEEN_OUTPUT_INFO') - if(err_occurred() /= 0) return + if (err_occurred() /= 0) return call read_value_integer(NTSTEP_BETWEEN_OUTPUT_SEISMOS, 'solver.NTSTEP_BETWEEN_OUTPUT_SEISMOS') - if(err_occurred() /= 0) return + if (err_occurred() /= 0) return call read_value_logical(PRINT_SOURCE_TIME_FUNCTION, 'solver.PRINT_SOURCE_TIME_FUNCTION') - if(err_occurred() /= 0) return + if (err_occurred() /= 0) return ! close parameter file close(IIN) diff --git a/utils/unused_routines/create_movie_GMT/read_value_parameters.f90 b/utils/unused_routines/create_movie_GMT/read_value_parameters.f90 index 3aa2f087a..be96f381c 100644 --- a/utils/unused_routines/create_movie_GMT/read_value_parameters.f90 +++ b/utils/unused_routines/create_movie_GMT/read_value_parameters.f90 @@ -105,17 +105,17 @@ subroutine read_next_line(string_read) do read(unit=IIN,fmt="(a100)",iostat=ios) string_read - if(ios /= 0) stop 'error while reading parameter file' + if (ios /= 0) stop 'error while reading parameter file' ! suppress leading white spaces, if any string_read = adjustl(string_read) ! suppress trailing carriage return (ASCII code 13) if any (e.g. if input text file coming from Windows/DOS) - if(index(string_read,achar(13)) > 0) string_read = string_read(1:index(string_read,achar(13))-1) + if (index(string_read,achar(13)) > 0) string_read = string_read(1:index(string_read,achar(13))-1) ! exit loop when we find the first line that is not a comment or a white line - if(len_trim(string_read) == 0) cycle - if(string_read(1:1) /= '#') exit + if (len_trim(string_read) == 0) cycle + if (string_read(1:1) /= '#') exit enddo @@ -123,11 +123,11 @@ subroutine read_next_line(string_read) string_read = string_read(1:len_trim(string_read)) ! suppress trailing comments, if any - if(index(string_read,'#') > 0) string_read = string_read(1:index(string_read,'#')-1) + if (index(string_read,'#') > 0) string_read = string_read(1:index(string_read,'#')-1) ! suppress leading junk (up to the first equal sign, included) index_equal_sign = index(string_read,'=') - if(index_equal_sign <= 1 .or. index_equal_sign == len_trim(string_read)) stop 'incorrect syntax detected in DATA/Par_file' + if (index_equal_sign <= 1 .or. index_equal_sign == len_trim(string_read)) stop 'incorrect syntax detected in DATA/Par_file' string_read = string_read(index_equal_sign + 1:len_trim(string_read)) ! suppress leading and trailing white spaces again, if any, after having suppressed the leading junk diff --git a/utils/unused_routines/create_movie_GMT/utm_geo.f90 b/utils/unused_routines/create_movie_GMT/utm_geo.f90 index d39001915..be0b23213 100644 --- a/utils/unused_routines/create_movie_GMT/utm_geo.f90 +++ b/utils/unused_routines/create_movie_GMT/utm_geo.f90 @@ -49,7 +49,7 @@ subroutine utm_geo(rlon,rlat,rx,ry,UTM_PROJECTION_ZONE,iway,SUPPRESS_UTM_PROJECT double precision f1,f2,f3,f4,rm,rn,t,c,a,e1,u,rlat1,dlat1,c1,t1,rn1,r1,d double precision rx_save,ry_save,rlon_save,rlat_save - if(SUPPRESS_UTM_PROJECTION) then + if (SUPPRESS_UTM_PROJECTION) then if (iway == ILONGLAT2UTM) then rx = rlon ry = rlat diff --git a/utils/unused_routines/define_subregions.f90 b/utils/unused_routines/define_subregions.f90 index 2df89acfb..bbab54a79 100644 --- a/utils/unused_routines/define_subregions.f90 +++ b/utils/unused_routines/define_subregions.f90 @@ -55,11 +55,11 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & ! !--- case of a regular mesh ! - if(USE_REGULAR_MESH) then + if (USE_REGULAR_MESH) then ! use two layers even for a regular mesh, because the algorithm detects the top of the mesh ! (the "topography") based on one layer of elements with flag IFLAG_ONE_LAYER_TOPOGRAPHY - if(isubregion == 2) then + if (isubregion == 2) then call usual_hex_nodes(iaddx,iaddy,iaddz) @@ -81,7 +81,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index = IFLAG_BASEMENT_TOPO - else if(isubregion == 1) then + else if (isubregion == 1) then call usual_hex_nodes(iaddx,iaddy,iaddz) @@ -115,7 +115,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & else ! this last region only defined when NER_SEDIM > 1 - if(isubregion == 30) then + if (isubregion == 30) then call usual_hex_nodes(iaddx,iaddy,iaddz) @@ -137,7 +137,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index = IFLAG_BASEMENT_TOPO - else if(isubregion == 29) then + else if (isubregion == 29) then call usual_hex_nodes(iaddx,iaddy,iaddz) @@ -159,7 +159,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index = IFLAG_ONE_LAYER_TOPOGRAPHY - else if(isubregion == 28) then + else if (isubregion == 28) then call usual_hex_nodes(iaddx,iaddy,iaddz) @@ -181,7 +181,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index= IFLAG_HALFSPACE_MOHO - else if(isubregion == 27) then + else if (isubregion == 27) then call unusual_hex_nodes1(iaddx,iaddy,iaddz) @@ -206,7 +206,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index=IFLAG_16km_BASEMENT - else if(isubregion == 26) then + else if (isubregion == 26) then call unusual_hex_nodes1p(iaddx,iaddy,iaddz) @@ -231,7 +231,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index=IFLAG_16km_BASEMENT - else if(isubregion == 25) then + else if (isubregion == 25) then call unusual_hex_nodes2(iaddx,iaddy,iaddz) @@ -256,7 +256,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index=IFLAG_16km_BASEMENT - else if(isubregion == 24) then + else if (isubregion == 24) then call unusual_hex_nodes2p(iaddx,iaddy,iaddz) @@ -281,7 +281,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index=IFLAG_16km_BASEMENT - else if(isubregion == 23) then + else if (isubregion == 23) then call unusual_hex_nodes3(iaddx,iaddy,iaddz) @@ -306,7 +306,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index=IFLAG_16km_BASEMENT - else if(isubregion == 22) then + else if (isubregion == 22) then call unusual_hex_nodes3(iaddx,iaddy,iaddz) @@ -331,7 +331,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index=IFLAG_16km_BASEMENT - else if(isubregion == 21) then + else if (isubregion == 21) then call unusual_hex_nodes4(iaddx,iaddy,iaddz) @@ -356,7 +356,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index=IFLAG_16km_BASEMENT - else if(isubregion == 20) then + else if (isubregion == 20) then call unusual_hex_nodes4p(iaddx,iaddy,iaddz) @@ -381,7 +381,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index=IFLAG_16km_BASEMENT - else if(isubregion == 19) then + else if (isubregion == 19) then call usual_hex_nodes(iaddx,iaddy,iaddz) @@ -406,7 +406,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index=IFLAG_16km_BASEMENT - else if(isubregion == 18) then + else if (isubregion == 18) then call usual_hex_nodes(iaddx,iaddy,iaddz) @@ -431,7 +431,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index=IFLAG_16km_BASEMENT - else if(isubregion == 17) then + else if (isubregion == 17) then call unusual_hex_nodes6(iaddx,iaddy,iaddz) @@ -456,7 +456,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index=IFLAG_16km_BASEMENT - else if(isubregion == 16) then + else if (isubregion == 16) then call unusual_hex_nodes6p(iaddx,iaddy,iaddz) @@ -481,7 +481,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index=IFLAG_16km_BASEMENT - else if(isubregion == 15) then + else if (isubregion == 15) then call usual_hex_nodes(iaddx,iaddy,iaddz) @@ -504,7 +504,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index = IFLAG_MOHO_16km - else if(isubregion == 14) then + else if (isubregion == 14) then call usual_hex_nodes(iaddx,iaddy,iaddz) @@ -528,7 +528,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index = IFLAG_16km_BASEMENT - else if(isubregion == 13) then + else if (isubregion == 13) then call usual_hex_nodes(iaddx,iaddy,iaddz) @@ -552,7 +552,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index=IFLAG_BASEMENT_TOPO - else if(isubregion == 12) then + else if (isubregion == 12) then call unusual_hex_nodes1(iaddx,iaddy,iaddz) @@ -577,7 +577,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index=IFLAG_BASEMENT_TOPO - else if(isubregion == 11) then + else if (isubregion == 11) then call unusual_hex_nodes1p(iaddx,iaddy,iaddz) @@ -602,7 +602,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index=IFLAG_BASEMENT_TOPO - else if(isubregion == 10) then + else if (isubregion == 10) then call unusual_hex_nodes2(iaddx,iaddy,iaddz) @@ -627,7 +627,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index=IFLAG_BASEMENT_TOPO - else if(isubregion == 9) then + else if (isubregion == 9) then call unusual_hex_nodes2p(iaddx,iaddy,iaddz) @@ -652,7 +652,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index=IFLAG_BASEMENT_TOPO - else if(isubregion == 8) then + else if (isubregion == 8) then call unusual_hex_nodes3(iaddx,iaddy,iaddz) @@ -677,7 +677,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index=IFLAG_BASEMENT_TOPO - else if(isubregion == 7) then + else if (isubregion == 7) then call unusual_hex_nodes3(iaddx,iaddy,iaddz) @@ -702,7 +702,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index=IFLAG_BASEMENT_TOPO - else if(isubregion == 6) then + else if (isubregion == 6) then call unusual_hex_nodes4(iaddx,iaddy,iaddz) @@ -727,7 +727,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index=IFLAG_BASEMENT_TOPO - else if(isubregion == 5) then + else if (isubregion == 5) then call unusual_hex_nodes4p(iaddx,iaddy,iaddz) @@ -752,7 +752,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index=IFLAG_BASEMENT_TOPO - else if(isubregion == 4) then + else if (isubregion == 4) then call usual_hex_nodes(iaddx,iaddy,iaddz) @@ -777,7 +777,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index=IFLAG_BASEMENT_TOPO - else if(isubregion == 3) then + else if (isubregion == 3) then call usual_hex_nodes(iaddx,iaddy,iaddz) @@ -802,7 +802,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index=IFLAG_BASEMENT_TOPO - else if(isubregion == 2) then + else if (isubregion == 2) then call unusual_hex_nodes6(iaddx,iaddy,iaddz) @@ -827,7 +827,7 @@ subroutine define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, & doubling_index=IFLAG_BASEMENT_TOPO - else if(isubregion == 1) then + else if (isubregion == 1) then call unusual_hex_nodes6p(iaddx,iaddy,iaddz) diff --git a/utils/unused_routines/define_subregions_heuristic.f90 b/utils/unused_routines/define_subregions_heuristic.f90 index 086e5796b..6300a03d7 100644 --- a/utils/unused_routines/define_subregions_heuristic.f90 +++ b/utils/unused_routines/define_subregions_heuristic.f90 @@ -58,7 +58,7 @@ subroutine define_subregions_heuristic(myrank,isubregion,iaddx,iaddy,iaddz, & ! ************** - if(isubregion == 8) then + if (isubregion == 8) then call unusual_hex_nodes1(iaddx,iaddy,iaddz) @@ -83,7 +83,7 @@ subroutine define_subregions_heuristic(myrank,isubregion,iaddx,iaddy,iaddz, & itype_element = ITYPE_UNUSUAL_1 - else if(isubregion == 7) then + else if (isubregion == 7) then call unusual_hex_nodes1p(iaddx,iaddy,iaddz) @@ -108,7 +108,7 @@ subroutine define_subregions_heuristic(myrank,isubregion,iaddx,iaddy,iaddz, & itype_element = ITYPE_UNUSUAL_1p - else if(isubregion == 6) then + else if (isubregion == 6) then call unusual_hex_nodes4(iaddx,iaddy,iaddz) @@ -133,7 +133,7 @@ subroutine define_subregions_heuristic(myrank,isubregion,iaddx,iaddy,iaddz, & itype_element = ITYPE_UNUSUAL_4 - else if(isubregion == 5) then + else if (isubregion == 5) then call unusual_hex_nodes4p(iaddx,iaddy,iaddz) @@ -158,7 +158,7 @@ subroutine define_subregions_heuristic(myrank,isubregion,iaddx,iaddy,iaddz, & itype_element = ITYPE_UNUSUAL_4p - else if(isubregion == 4) then + else if (isubregion == 4) then call unusual_hex_nodes1(iaddx,iaddy,iaddz) @@ -183,7 +183,7 @@ subroutine define_subregions_heuristic(myrank,isubregion,iaddx,iaddy,iaddz, & itype_element = ITYPE_UNUSUAL_1 - else if(isubregion == 3) then + else if (isubregion == 3) then call unusual_hex_nodes1p(iaddx,iaddy,iaddz) @@ -208,7 +208,7 @@ subroutine define_subregions_heuristic(myrank,isubregion,iaddx,iaddy,iaddz, & itype_element = ITYPE_UNUSUAL_1p - else if(isubregion == 2) then + else if (isubregion == 2) then call unusual_hex_nodes4(iaddx,iaddy,iaddz) @@ -233,7 +233,7 @@ subroutine define_subregions_heuristic(myrank,isubregion,iaddx,iaddy,iaddz, & itype_element = ITYPE_UNUSUAL_4 - else if(isubregion == 1) then + else if (isubregion == 1) then call unusual_hex_nodes4p(iaddx,iaddy,iaddz) diff --git a/utils/unused_routines/from_old_DATA/hauksson_model/regrid_hauksson_regular.f90 b/utils/unused_routines/from_old_DATA/hauksson_model/regrid_hauksson_regular.f90 index 8a408b0f1..3d0710fb4 100644 --- a/utils/unused_routines/from_old_DATA/hauksson_model/regrid_hauksson_regular.f90 +++ b/utils/unused_routines/from_old_DATA/hauksson_model/regrid_hauksson_regular.f90 @@ -38,7 +38,7 @@ program jfdkfd distmin = +100000000000.d0 do iold=1,NLINES_HAUKSSON_DENSER dist = dsqrt((utm_x_new(i,j) - utm_x_ori(iold))**2 + (utm_y_new(i,j) - utm_y_ori(iold))**2) - if(dist < distmin) then + if (dist < distmin) then ic = iold distmin = dist endif diff --git a/utils/unused_routines/from_old_DATA/hauksson_model/smooth_final_hauksson.f90 b/utils/unused_routines/from_old_DATA/hauksson_model/smooth_final_hauksson.f90 index 4f8d2ce86..af2e4a1ce 100644 --- a/utils/unused_routines/from_old_DATA/hauksson_model/smooth_final_hauksson.f90 +++ b/utils/unused_routines/from_old_DATA/hauksson_model/smooth_final_hauksson.f90 @@ -31,10 +31,10 @@ program jfdkfd do jloop = j-NSIZE,j+NSIZE ival = iloop jval = jloop - if(ival<1) ival = 1 - if(jval<1) jval = 1 - if(ival>NGRID_NEW_HAUKSSON) ival = NGRID_NEW_HAUKSSON - if(jval>NGRID_NEW_HAUKSSON) jval = NGRID_NEW_HAUKSSON + if (ival<1) ival = 1 + if (jval<1) jval = 1 + if (ival>NGRID_NEW_HAUKSSON) ival = NGRID_NEW_HAUKSSON + if (jval>NGRID_NEW_HAUKSSON) jval = NGRID_NEW_HAUKSSON meanval = meanval + value_old(ivalue,ival,jval) enddo enddo diff --git a/utils/unused_routines/from_old_DATA/la_3D_block_harvard/la_3D_high_res/read_gocad_block_extract_highres.f90 b/utils/unused_routines/from_old_DATA/la_3D_block_harvard/la_3D_high_res/read_gocad_block_extract_highres.f90 index a123126da..484cbd10d 100644 --- a/utils/unused_routines/from_old_DATA/la_3D_block_harvard/la_3D_high_res/read_gocad_block_extract_highres.f90 +++ b/utils/unused_routines/from_old_DATA/la_3D_block_harvard/la_3D_high_res/read_gocad_block_extract_highres.f90 @@ -77,7 +77,7 @@ program read_gocad_block_extract ! extend basin model below threshold to bottom of the grid to make sure ! there is no small gap between interpolated basement map and sediments - if(EXTEND_VOXET_BELOW_BASEMENT) then + if (EXTEND_VOXET_BELOW_BASEMENT) then do ix = 0,NX_GOCAD_HR-1 do iy = 0,NY_GOCAD_HR-1 @@ -85,11 +85,11 @@ program read_gocad_block_extract ! a fictitious P velocity of -9999 km/s has been used to flag fictitious points iz_found = -1 do iz = NZ_GOCAD_HR-1,0,-1 - if(vp_block_gocad(ix,iy,iz) < 6499.) iz_found = iz + if (vp_block_gocad(ix,iy,iz) < 6499.) iz_found = iz enddo ! if some sediments are detected on this vertical line in Voxet - if(iz_found > -1) then + if (iz_found > -1) then ! define Gocad grid, shift of Voxet is taken into account zsedim_found = ORIG_Z_GOCAD_HR + iz_found*SPACING_Z_GOCAD_HR @@ -98,7 +98,7 @@ program read_gocad_block_extract ! therefore we can safely extend below to make sure we leave no small gap ! between our mesh and the Gocad voxet (because we interpolate the basement ! slightly differently from what has been done in Gocad at Harvard) - if(zsedim_found <= Z_THRESHOLD_HONOR_BASEMENT) then + if (zsedim_found <= Z_THRESHOLD_HONOR_BASEMENT) then do iz = max(1,iz_found-NCELLS_EXTEND),iz_found-1 vp_block_gocad(ix,iy,iz) = vp_block_gocad(ix,iy,iz_found) enddo @@ -115,7 +115,7 @@ program read_gocad_block_extract ! also make sure there are no gaps between topography and sediments ! because we also define topography slightly differently from Gocad - if(EXTEND_VOXET_ABOVE_TOPO) then + if (EXTEND_VOXET_ABOVE_TOPO) then print *,'reading topography from file to fill small gaps' call read_basin_topo_bathy_file(itopo_bathy_basin) @@ -132,11 +132,11 @@ program read_gocad_block_extract ! a fictitious P velocity of -9999 km/s has been used to flag fictitious points iz_found = -1 do iz = 0,NZ_GOCAD_HR-1 - if(vp_block_gocad(ix,iy,iz) < 6499.) iz_found = iz + if (vp_block_gocad(ix,iy,iz) < 6499.) iz_found = iz enddo ! if some sediments are detected on this vertical line in Voxet - if(iz_found > -1) then + if (iz_found > -1) then ! define Gocad grid, shift of Voxet is taken into account xcoord = ORIG_X_GOCAD_HR + ix*SPACING_X_GOCAD_HR @@ -151,22 +151,22 @@ program read_gocad_block_extract iclosestlat = nint((lat - ORIG_LAT) / DEGREES_PER_CELL) + 1 ! avoid edge effects and extend with identical topo if point outside model - if(iclosestlong < 1) iclosestlong = 1 - if(iclosestlong > NX_TOPO) iclosestlong = NX_TOPO + if (iclosestlong < 1) iclosestlong = 1 + if (iclosestlong > NX_TOPO) iclosestlong = NX_TOPO - if(iclosestlat < 1) iclosestlat = 1 - if(iclosestlat > NY_TOPO) iclosestlat = NY_TOPO + if (iclosestlat < 1) iclosestlat = 1 + if (iclosestlat > NY_TOPO) iclosestlat = NY_TOPO ! compute elevation at current point elevation = dble(itopo_bathy_basin(iclosestlong,iclosestlat)) ! if distance is negative, it means our topo is below Gocad topo ! compute maximum to estimate maximum error between the two surfaces - if(elevation - zsedim_found < 0.d0) max_error = dmax1(max_error,dabs(elevation - zsedim_found)) + if (elevation - zsedim_found < 0.d0) max_error = dmax1(max_error,dabs(elevation - zsedim_found)) ! if point is not too far from topo, assume sediments should reach the surface, ! and fill the gap and extend above topo to be safe - if(elevation - zsedim_found < DISTMAX_ASSUME_SEDIMENTS) then + if (elevation - zsedim_found < DISTMAX_ASSUME_SEDIMENTS) then do iz = iz_found+1,min(iz_found+NCELLS_EXTEND,NZ_GOCAD_HR-1) vp_block_gocad(ix,iy,iz) = vp_block_gocad(ix,iy,iz_found) enddo @@ -199,9 +199,9 @@ program read_gocad_block_extract ! exclude points that are undefined ! a fictitious P velocity of 6501 km/s has been used to flag these points !!!! DK DK UGLY CRADE ugly to extract only one layer for AVS -!!!! DK DK UGLY CRADE if(vp_block_gocad(ix,iy,iz) > 6499. .or. (iz /= 90 .and. iz /= 91)) then +!!!! DK DK UGLY CRADE if (vp_block_gocad(ix,iy,iz) > 6499. .or. (iz /= 90 .and. iz /= 91)) then - if(vp_block_gocad(ix,iy,iz) > 6499.) then + if (vp_block_gocad(ix,iy,iz) > 6499.) then icount_undefined = icount_undefined + 1 iflag_point(ix,iy,iz) = .false. @@ -232,7 +232,7 @@ program read_gocad_block_extract do ix = 0,NX_GOCAD_HR-1 do iy = 0,NY_GOCAD_HR-1 do iz = 0,NZ_GOCAD_HR-1 - if(iflag_point(ix,iy,iz)) write(27,*) ix,' ',iy,' ',iz,' ',nint(vp_block_gocad(ix,iy,iz)) + if (iflag_point(ix,iy,iz)) write(27,*) ix,' ',iy,' ',iz,' ',nint(vp_block_gocad(ix,iy,iz)) enddo enddo enddo @@ -246,7 +246,7 @@ program read_gocad_block_extract do iz = 0,NZ_GOCAD_HR-2 ! suppress elements that are undefined - if(iflag_point(ix,iy,iz) .and. & + if (iflag_point(ix,iy,iz) .and. & iflag_point(ix+1,iy,iz) .and. & iflag_point(ix+1,iy+1,iz) .and. & iflag_point(ix,iy+1,iz) .and. & @@ -289,7 +289,7 @@ program read_gocad_block_extract do iy = 0,NY_GOCAD_HR-1 do iz = 0,NZ_GOCAD_HR-1 - if(iflag_point(ix,iy,iz)) then + if (iflag_point(ix,iy,iz)) then ipoin = ipoin + 1 ! define Gocad grid, shift of Voxet is taken into account @@ -311,7 +311,7 @@ program read_gocad_block_extract do iz = 0,NZ_GOCAD_HR-2 ! suppress elements that are undefined - if(iflag_point(ix,iy,iz) .and. & + if (iflag_point(ix,iy,iz) .and. & iflag_point(ix+1,iy,iz) .and. & iflag_point(ix+1,iy+1,iz) .and. & iflag_point(ix,iy+1,iz) .and. & @@ -324,7 +324,7 @@ program read_gocad_block_extract ! use Z > 0 and Z < 0 to define material flag zcoord = ORIG_Z_GOCAD_HR + iz*SPACING_Z_GOCAD_HR - if(zcoord <= 0.) then + if (zcoord <= 0.) then imaterial = 1 else imaterial = 2 @@ -352,7 +352,7 @@ program read_gocad_block_extract do ix = 0,NX_GOCAD_HR-1 do iy = 0,NY_GOCAD_HR-1 do iz = 0,NZ_GOCAD_HR-1 - if(iflag_point(ix,iy,iz)) then + if (iflag_point(ix,iy,iz)) then ipoin = ipoin + 1 ! use Vp to color the model @@ -360,7 +360,7 @@ program read_gocad_block_extract ! or use Z > 0 and Z < 0 to color the model ! zcoord = ORIG_Z_GOCAD_HR + iz*SPACING_Z_GOCAD_HR -! if(zcoord <= 0.) then +! if (zcoord <= 0.) then ! write(11,*) ipoin,' 0.' ! else ! write(11,*) ipoin,' 255.' diff --git a/utils/unused_routines/from_old_DATA/la_3D_block_harvard/la_3D_high_res/reformat_initial_block_peter.f90 b/utils/unused_routines/from_old_DATA/la_3D_block_harvard/la_3D_high_res/reformat_initial_block_peter.f90 index 0468b49be..53017b23f 100644 --- a/utils/unused_routines/from_old_DATA/la_3D_block_harvard/la_3D_high_res/reformat_initial_block_peter.f90 +++ b/utils/unused_routines/from_old_DATA/la_3D_block_harvard/la_3D_high_res/reformat_initial_block_peter.f90 @@ -64,8 +64,8 @@ program read_gocad_block_extract read(27,rec=irecord) vp_block_gocad_sngl(ix,iy,iz) ! use only one convention for threshold: vp > 6500. means fictitious - if(vp_block_gocad_sngl(ix,iy,iz) < 0.1) vp_block_gocad_sngl(ix,iy,iz) = 6501. - if(vp_block_gocad_sngl(ix,iy,iz) > 6499.) vp_block_gocad_sngl(ix,iy,iz) = 6501. + if (vp_block_gocad_sngl(ix,iy,iz) < 0.1) vp_block_gocad_sngl(ix,iy,iz) = 6501. + if (vp_block_gocad_sngl(ix,iy,iz) > 6499.) vp_block_gocad_sngl(ix,iy,iz) = 6501. ! invert Y and Z axes back to normal vp_block_gocad_sngl_clean(ix,NY_GOCAD_HR-1-iy,NZ_GOCAD_HR-1-iz) = vp_block_gocad_sngl(ix,iy,iz) diff --git a/utils/unused_routines/from_old_DATA/la_3D_block_harvard/la_3D_medium_res/check_block_openDX.f90 b/utils/unused_routines/from_old_DATA/la_3D_block_harvard/la_3D_medium_res/check_block_openDX.f90 index a9057c9e2..37d8677c0 100644 --- a/utils/unused_routines/from_old_DATA/la_3D_block_harvard/la_3D_medium_res/check_block_openDX.f90 +++ b/utils/unused_routines/from_old_DATA/la_3D_block_harvard/la_3D_medium_res/check_block_openDX.f90 @@ -45,7 +45,7 @@ program read_gocad_block_extract read(27,*) nrecord do irecord = 1,nrecord read(27,*) ix,iy,iz,i_vp - if(ix<0 .or. ix>NX_GOCAD_MR-1 .or. iy<0 .or. iy>NY_GOCAD_MR-1 .or. iz<0 .or. iz>NZ_GOCAD_MR-1) & + if (ix<0 .or. ix>NX_GOCAD_MR-1 .or. iy<0 .or. iy>NY_GOCAD_MR-1 .or. iz<0 .or. iz>NZ_GOCAD_MR-1) & stop 'wrong array index read in Gocad medium-resolution file' vp_block_gocad(ix,iy,iz) = dble(i_vp) enddo @@ -65,7 +65,7 @@ program read_gocad_block_extract ! exclude points that are undefined ! a negative P velocity has been used to flag these points - if(vp_block_gocad(ix,iy,iz) < 1.) then + if (vp_block_gocad(ix,iy,iz) < 1.) then icount_undefined = icount_undefined + 1 iflag_point(ix,iy,iz) = .false. @@ -92,7 +92,7 @@ program read_gocad_block_extract do iz = 0,NZ_GOCAD_MR-2 ! suppress elements that are undefined - if(iflag_point(ix,iy,iz) .and. & + if (iflag_point(ix,iy,iz) .and. & iflag_point(ix+1,iy,iz) .and. & iflag_point(ix+1,iy+1,iz) .and. & iflag_point(ix,iy+1,iz) .and. & @@ -134,7 +134,7 @@ program read_gocad_block_extract do iy = 0,NY_GOCAD_MR-1 do iz = 0,NZ_GOCAD_MR-1 - if(iflag_point(ix,iy,iz)) then + if (iflag_point(ix,iy,iz)) then ipoin = ipoin + 1 ! define Gocad grid, shift of Voxet is taken into account @@ -158,7 +158,7 @@ program read_gocad_block_extract do iz = 0,NZ_GOCAD_MR-2 ! suppress elements that are undefined - if(iflag_point(ix,iy,iz) .and. & + if (iflag_point(ix,iy,iz) .and. & iflag_point(ix+1,iy,iz) .and. & iflag_point(ix+1,iy+1,iz) .and. & iflag_point(ix,iy+1,iz) .and. & @@ -196,7 +196,7 @@ program read_gocad_block_extract do ix = 0,NX_GOCAD_MR-1 do iy = 0,NY_GOCAD_MR-1 do iz = 0,NZ_GOCAD_MR-1 - if(iflag_point(ix,iy,iz)) then + if (iflag_point(ix,iy,iz)) then ipoin = ipoin + 1 ! use Vp to color the model @@ -204,7 +204,7 @@ program read_gocad_block_extract ! or use Z > 0 and Z < 0 to color the model zcoord = ORIG_Z_GOCAD_MR + iz*SPACING_Z_GOCAD_MR - if(zcoord <= 0.) then + if (zcoord <= 0.) then write(11,*) '0' else write(11,*) '255' diff --git a/utils/unused_routines/from_old_DATA/la_3D_block_harvard/la_3D_medium_res/read_gocad_block_extract_mediumres.f90 b/utils/unused_routines/from_old_DATA/la_3D_block_harvard/la_3D_medium_res/read_gocad_block_extract_mediumres.f90 index b1b56c677..e49d5a4f9 100644 --- a/utils/unused_routines/from_old_DATA/la_3D_block_harvard/la_3D_medium_res/read_gocad_block_extract_mediumres.f90 +++ b/utils/unused_routines/from_old_DATA/la_3D_block_harvard/la_3D_medium_res/read_gocad_block_extract_mediumres.f90 @@ -66,7 +66,7 @@ program read_gocad_block_extract ! extend basin model below threshold to bottom of the grid to make sure ! there is no small gap between interpolated basement map and sediments - if(EXTEND_VOXET_BELOW_BASEMENT) then + if (EXTEND_VOXET_BELOW_BASEMENT) then do ix = 0,NX_GOCAD_MR-1 do iy = 0,NY_GOCAD_MR-1 @@ -74,11 +74,11 @@ program read_gocad_block_extract ! a negative P velocity has been used to flag fictitious points iz_found = -1 do iz = NZ_GOCAD_MR-1,0,-1 - if(vp_block_gocad(ix,iy,iz) > 1.) iz_found = iz + if (vp_block_gocad(ix,iy,iz) > 1.) iz_found = iz enddo ! if some sediments are detected on this vertical line in Voxet - if(iz_found > -1) then + if (iz_found > -1) then ! define Gocad grid, shift of Voxet is taken into account zsedim_found = ORIG_Z_GOCAD_MR + iz_found*SPACING_Z_GOCAD_MR @@ -87,7 +87,7 @@ program read_gocad_block_extract ! therefore we can safely extend below to make sure we leave no small gap ! between our mesh and the Gocad voxet (because we interpolate the basement ! slightly differently from what has been done in Gocad at Harvard) - if(zsedim_found <= Z_THRESHOLD_HONOR_BASEMENT) then + if (zsedim_found <= Z_THRESHOLD_HONOR_BASEMENT) then do iz = max(1,iz_found-NCELLS_EXTEND),iz_found-1 vp_block_gocad(ix,iy,iz) = vp_block_gocad(ix,iy,iz_found) enddo @@ -104,7 +104,7 @@ program read_gocad_block_extract ! also make sure there are no gaps between topography and sediments ! because we also define topography slightly differently from Gocad - if(EXTEND_VOXET_ABOVE_TOPO) then + if (EXTEND_VOXET_ABOVE_TOPO) then print *,'reading topography from file to fill small gaps' call read_basin_topo_bathy_file(itopo_bathy_basin) @@ -121,11 +121,11 @@ program read_gocad_block_extract ! a negative P velocity has been used to flag fictitious points iz_found = -1 do iz = 0,NZ_GOCAD_MR-1 - if(vp_block_gocad(ix,iy,iz) > 1.) iz_found = iz + if (vp_block_gocad(ix,iy,iz) > 1.) iz_found = iz enddo ! if some sediments are detected on this vertical line in Voxet - if(iz_found > -1) then + if (iz_found > -1) then ! define Gocad grid, shift of Voxet is taken into account xcoord = ORIG_X_GOCAD_MR + ix*SPACING_X_GOCAD_MR @@ -140,22 +140,22 @@ program read_gocad_block_extract iclosestlat = nint((lat - ORIG_LAT) / DEGREES_PER_CELL) + 1 ! avoid edge effects and extend with identical topo if point outside model - if(iclosestlong < 1) iclosestlong = 1 - if(iclosestlong > NX_TOPO) iclosestlong = NX_TOPO + if (iclosestlong < 1) iclosestlong = 1 + if (iclosestlong > NX_TOPO) iclosestlong = NX_TOPO - if(iclosestlat < 1) iclosestlat = 1 - if(iclosestlat > NY_TOPO) iclosestlat = NY_TOPO + if (iclosestlat < 1) iclosestlat = 1 + if (iclosestlat > NY_TOPO) iclosestlat = NY_TOPO ! compute elevation at current point elevation = dble(itopo_bathy_basin(iclosestlong,iclosestlat)) ! if distance is negative, it means our topo is below Gocad topo ! compute maximum to estimate maximum error between the two surfaces - if(elevation - zsedim_found < 0.d0) max_error = dmax1(max_error,dabs(elevation - zsedim_found)) + if (elevation - zsedim_found < 0.d0) max_error = dmax1(max_error,dabs(elevation - zsedim_found)) ! if point is not too far from topo, assume sediments should reach the surface, ! and fill the gap and extend above topo to be safe - if(elevation - zsedim_found < DISTMAX_ASSUME_SEDIMENTS) then + if (elevation - zsedim_found < DISTMAX_ASSUME_SEDIMENTS) then do iz = iz_found+1,min(iz_found+NCELLS_EXTEND,NZ_GOCAD_MR-1) vp_block_gocad(ix,iy,iz) = vp_block_gocad(ix,iy,iz_found) enddo @@ -186,7 +186,7 @@ program read_gocad_block_extract ! exclude points that are undefined ! a negative P velocity has been used to flag these points - if(vp_block_gocad(ix,iy,iz) < 1.) then + if (vp_block_gocad(ix,iy,iz) < 1.) then icount_undefined = icount_undefined + 1 iflag_point(ix,iy,iz) = .false. @@ -217,7 +217,7 @@ program read_gocad_block_extract do ix = 0,NX_GOCAD_MR-1 do iy = 0,NY_GOCAD_MR-1 do iz = 0,NZ_GOCAD_MR-1 - if(iflag_point(ix,iy,iz)) write(27,*) ix,' ',iy,' ',iz,' ',nint(vp_block_gocad(ix,iy,iz)) + if (iflag_point(ix,iy,iz)) write(27,*) ix,' ',iy,' ',iz,' ',nint(vp_block_gocad(ix,iy,iz)) enddo enddo enddo @@ -231,7 +231,7 @@ program read_gocad_block_extract do iz = 0,NZ_GOCAD_MR-2 ! suppress elements that are undefined - if(iflag_point(ix,iy,iz) .and. & + if (iflag_point(ix,iy,iz) .and. & iflag_point(ix+1,iy,iz) .and. & iflag_point(ix+1,iy+1,iz) .and. & iflag_point(ix,iy+1,iz) .and. & @@ -274,7 +274,7 @@ program read_gocad_block_extract do iy = 0,NY_GOCAD_MR-1 do iz = 0,NZ_GOCAD_MR-1 - if(iflag_point(ix,iy,iz)) then + if (iflag_point(ix,iy,iz)) then ipoin = ipoin + 1 ! define Gocad grid, shift of Voxet is taken into account @@ -296,7 +296,7 @@ program read_gocad_block_extract do iz = 0,NZ_GOCAD_MR-2 ! suppress elements that are undefined - if(iflag_point(ix,iy,iz) .and. & + if (iflag_point(ix,iy,iz) .and. & iflag_point(ix+1,iy,iz) .and. & iflag_point(ix+1,iy+1,iz) .and. & iflag_point(ix,iy+1,iz) .and. & @@ -309,7 +309,7 @@ program read_gocad_block_extract ! use Z > 0 and Z < 0 to define material flag zcoord = ORIG_Z_GOCAD_MR + iz*SPACING_Z_GOCAD_MR - if(zcoord <= 0.) then + if (zcoord <= 0.) then imaterial = 1 else imaterial = 2 @@ -337,7 +337,7 @@ program read_gocad_block_extract do ix = 0,NX_GOCAD_MR-1 do iy = 0,NY_GOCAD_MR-1 do iz = 0,NZ_GOCAD_MR-1 - if(iflag_point(ix,iy,iz)) then + if (iflag_point(ix,iy,iz)) then ipoin = ipoin + 1 ! use Vp to color the model @@ -345,7 +345,7 @@ program read_gocad_block_extract ! or use Z > 0 and Z < 0 to color the model ! zcoord = ORIG_Z_GOCAD_MR + iz*SPACING_Z_GOCAD_MR -! if(zcoord <= 0.) then +! if (zcoord <= 0.) then ! write(11,*) ipoin,' 0.' ! else ! write(11,*) ipoin,' 255.' diff --git a/utils/unused_routines/from_old_DATA/la_basement/read_basement_surface_AVS.f90 b/utils/unused_routines/from_old_DATA/la_basement/read_basement_surface_AVS.f90 index a39ba2d5b..deefdbc2a 100644 --- a/utils/unused_routines/from_old_DATA/la_basement/read_basement_surface_AVS.f90 +++ b/utils/unused_routines/from_old_DATA/la_basement/read_basement_surface_AVS.f90 @@ -23,8 +23,8 @@ program read_basement_surf read(*,*) idummy,utm_x(iline_x,iline_y),utm_y(iline_x,iline_y),z_value(iline_x,iline_y),zdummy1,zdummy2 ! apply threshold to get bottom of basin only - if(APPLY_THRESHOLD_BASEMENT) then - if(z_value(iline_x,iline_y) > Z_THRESHOLD_HONOR_BASEMENT) & + if (APPLY_THRESHOLD_BASEMENT) then + if (z_value(iline_x,iline_y) > Z_THRESHOLD_HONOR_BASEMENT) & z_value(iline_x,iline_y) = Z_THRESHOLD_HONOR_BASEMENT endif diff --git a/utils/unused_routines/from_old_DATA/la_topography/merge_filter_ori_bathy_topo.f90 b/utils/unused_routines/from_old_DATA/la_topography/merge_filter_ori_bathy_topo.f90 index e7bc7b7b9..59ad25a2d 100644 --- a/utils/unused_routines/from_old_DATA/la_topography/merge_filter_ori_bathy_topo.f90 +++ b/utils/unused_routines/from_old_DATA/la_topography/merge_filter_ori_bathy_topo.f90 @@ -36,11 +36,11 @@ program merge_filter_ori_bathy_topo read(13,*) a,b,ic ix = nint((b-ORIG_LONG)/DEGREES_PER_CELL_BATHY) iy = nint((a-ORIG_LAT)/DEGREES_PER_CELL_BATHY) - if(ix < 1) ix = 1 - if(ix > NX_BATHY) ix = NX_BATHY - if(iy < 1) iy = 1 - if(iy > NY_BATHY) iy = NY_BATHY - if(ic <= 0) stop 'incorrect bathy point' + if (ix < 1) ix = 1 + if (ix > NX_BATHY) ix = NX_BATHY + if (iy < 1) iy = 1 + if (iy > NY_BATHY) iy = NY_BATHY + if (ic <= 0) stop 'incorrect bathy point' ibathy_read(ix,iy) = - ic enddo close(13) @@ -50,13 +50,13 @@ program merge_filter_ori_bathy_topo ! remove zeros (spikes) from raw file do iy=1,NY_BATHY do ix=1,NX_BATHY-1 - if(ibathy_read(ix,iy) >= 0) ibathy(ix,iy) = ibathy_read(ix+1,iy) + if (ibathy_read(ix,iy) >= 0) ibathy(ix,iy) = ibathy_read(ix+1,iy) enddo enddo do iy=1,NY_BATHY-1 do ix=1,NX_BATHY - if(ibathy_read(ix,iy) >= 0) ibathy(ix,iy) = ibathy_read(ix,iy+1) + if (ibathy_read(ix,iy) >= 0) ibathy(ix,iy) = ibathy_read(ix,iy+1) enddo enddo @@ -91,32 +91,32 @@ program merge_filter_ori_bathy_topo print *,'interpolating bathy onto topo grid' do iy = 1,NY_TOPO do ix = 1,NX_TOPO - if(itopo(ix,iy) <= 0) then + if (itopo(ix,iy) <= 0) then rlon = ORIG_LONG + (ix-1)*DEGREES_PER_CELL rlat = ORIG_LAT + (iy-1)*DEGREES_PER_CELL ixconv = nint((rlon - ORIG_LONG)/DEGREES_PER_CELL_BATHY + 1) iyconv = nint((rlat - ORIG_LAT)/DEGREES_PER_CELL_BATHY + 1) - if(ixconv < 1) ixconv = 1 - if(iyconv < 1) iyconv = 1 - if(ixconv > NX_BATHY) ixconv = NX_BATHY - if(iyconv > NY_BATHY) iyconv = NY_BATHY + if (ixconv < 1) ixconv = 1 + if (iyconv < 1) iyconv = 1 + if (ixconv > NX_BATHY) ixconv = NX_BATHY + if (iyconv > NY_BATHY) iyconv = NY_BATHY itopo(ix,iy) = ibathy(ixconv,iyconv) endif enddo enddo ! truncate topo in Sierra Nevada to avoid artefacts - if(TRUNCATE_TOPO) then + if (TRUNCATE_TOPO) then print *,'truncating topo above ',MAX_TOPO do iy = 1,NY_TOPO do ix = 1,NX_TOPO - if(itopo(ix,iy) > MAX_TOPO) itopo(ix,iy) = MAX_TOPO + if (itopo(ix,iy) > MAX_TOPO) itopo(ix,iy) = MAX_TOPO enddo enddo endif ! filter final surface using box filter - if(FILTER_USING_BOX) then + if (FILTER_USING_BOX) then print *,'filtering final surface using box filter' do iy = 1,NY_TOPO print *,'doing iy = ',iy,' out of ',NY_TOPO @@ -126,10 +126,10 @@ program merge_filter_ori_bathy_topo do ixbox = ix-SIZE_FILTER_ONE_SIDE,ix+SIZE_FILTER_ONE_SIDE ixval = ixbox iyval = iybox - if(ixval < 1) ixval = 1 - if(iyval < 1) iyval = 1 - if(ixval > NX_TOPO) ixval = NX_TOPO - if(iyval > NY_TOPO) iyval = NY_TOPO + if (ixval < 1) ixval = 1 + if (iyval < 1) iyval = 1 + if (ixval > NX_TOPO) ixval = NX_TOPO + if (iyval > NY_TOPO) iyval = NY_TOPO sumval = sumval + dble(itopo(ixval,iyval)) enddo enddo diff --git a/utils/unused_routines/from_old_DATA/lin_model/hauksson_model.f90 b/utils/unused_routines/from_old_DATA/lin_model/hauksson_model.f90 index 87e2e512a..a17a1eb23 100644 --- a/utils/unused_routines/from_old_DATA/lin_model/hauksson_model.f90 +++ b/utils/unused_routines/from_old_DATA/lin_model/hauksson_model.f90 @@ -55,8 +55,8 @@ subroutine hauksson_model(vp,vs,utm_x_eval,utm_y_eval,z_eval,vp_final,vs_final,M utm_y_eval_copy = utm_y_eval ! make sure we stay inside Hauksson's grid - if(utm_x_eval_copy < UTM_X_ORIG_HAUKSSON) utm_x_eval_copy = UTM_X_ORIG_HAUKSSON - if(utm_y_eval_copy < UTM_Y_ORIG_HAUKSSON) utm_y_eval_copy = UTM_Y_ORIG_HAUKSSON + if (utm_x_eval_copy < UTM_X_ORIG_HAUKSSON) utm_x_eval_copy = UTM_X_ORIG_HAUKSSON + if (utm_y_eval_copy < UTM_Y_ORIG_HAUKSSON) utm_y_eval_copy = UTM_Y_ORIG_HAUKSSON ! determine spacing and cell for linear interpolation spacing_x = (utm_x_eval_copy - UTM_X_ORIG_HAUKSSON) / SPACING_UTM_X_HAUKSSON @@ -69,28 +69,28 @@ subroutine hauksson_model(vp,vs,utm_x_eval,utm_y_eval,z_eval,vp_final,vs_final,M gamma_interp_y = spacing_y - int(spacing_y) ! suppress edge effects for points outside of Hauksson's model - if(icell_interp_x < 1) then + if (icell_interp_x < 1) then icell_interp_x = 1 gamma_interp_x = 0.d0 endif - if(icell_interp_x > NGRID_NEW_HAUKSSON-1) then + if (icell_interp_x > NGRID_NEW_HAUKSSON-1) then icell_interp_x = NGRID_NEW_HAUKSSON-1 gamma_interp_x = 1.d0 endif - if(icell_interp_y < 1) then + if (icell_interp_y < 1) then icell_interp_y = 1 gamma_interp_y = 0.d0 endif - if(icell_interp_y > NGRID_NEW_HAUKSSON-1) then + if (icell_interp_y > NGRID_NEW_HAUKSSON-1) then icell_interp_y = NGRID_NEW_HAUKSSON-1 gamma_interp_y = 1.d0 endif ! make sure interpolation makes sense - if(gamma_interp_x < -0.001d0 .or. gamma_interp_x > 1.001d0) & + if (gamma_interp_x < -0.001d0 .or. gamma_interp_x > 1.001d0) & stop 'interpolation in x is incorrect in Hauksson' - if(gamma_interp_y < -0.001d0 .or. gamma_interp_y > 1.001d0) & + if (gamma_interp_y < -0.001d0 .or. gamma_interp_y > 1.001d0) & stop 'interpolation in y is incorrect in Hauksson' ! interpolate Hauksson's model at right location using bilinear interpolation @@ -121,17 +121,17 @@ subroutine hauksson_model(vp,vs,utm_x_eval,utm_y_eval,z_eval,vp_final,vs_final,M enddo ! choose right values depending on depth of target point - if(z_eval >= Z_HAUKSSON_LAYER_1) then + if (z_eval >= Z_HAUKSSON_LAYER_1) then vp_final = vp_interp(1) vs_final = vs_interp(1) return - else if(z_eval <= Z_HAUKSSON_LAYER_8) then + else if (z_eval <= Z_HAUKSSON_LAYER_8) then vp_final = vp_interp(8) vs_final = vs_interp(8) return - else if(z_eval >= Z_HAUKSSON_LAYER_2) then + else if (z_eval >= Z_HAUKSSON_LAYER_2) then vp_upper = vp_interp(1) vs_upper = vs_interp(1) z_upper = Z_HAUKSSON_LAYER_1 @@ -140,7 +140,7 @@ subroutine hauksson_model(vp,vs,utm_x_eval,utm_y_eval,z_eval,vp_final,vs_final,M vs_lower = vs_interp(2) z_lower = Z_HAUKSSON_LAYER_2 - else if(z_eval >= Z_HAUKSSON_LAYER_3) then + else if (z_eval >= Z_HAUKSSON_LAYER_3) then vp_upper = vp_interp(2) vs_upper = vs_interp(2) z_upper = Z_HAUKSSON_LAYER_2 @@ -149,7 +149,7 @@ subroutine hauksson_model(vp,vs,utm_x_eval,utm_y_eval,z_eval,vp_final,vs_final,M vs_lower = vs_interp(3) z_lower = Z_HAUKSSON_LAYER_3 - else if(z_eval >= Z_HAUKSSON_LAYER_4) then + else if (z_eval >= Z_HAUKSSON_LAYER_4) then vp_upper = vp_interp(3) vs_upper = vs_interp(3) z_upper = Z_HAUKSSON_LAYER_3 @@ -158,7 +158,7 @@ subroutine hauksson_model(vp,vs,utm_x_eval,utm_y_eval,z_eval,vp_final,vs_final,M vs_lower = vs_interp(4) z_lower = Z_HAUKSSON_LAYER_4 - else if(z_eval >= Z_HAUKSSON_LAYER_5) then + else if (z_eval >= Z_HAUKSSON_LAYER_5) then vp_upper = vp_interp(4) vs_upper = vs_interp(4) z_upper = Z_HAUKSSON_LAYER_4 @@ -167,7 +167,7 @@ subroutine hauksson_model(vp,vs,utm_x_eval,utm_y_eval,z_eval,vp_final,vs_final,M vs_lower = vs_interp(5) z_lower = Z_HAUKSSON_LAYER_5 - else if(z_eval >= Z_HAUKSSON_LAYER_6) then + else if (z_eval >= Z_HAUKSSON_LAYER_6) then vp_upper = vp_interp(5) vs_upper = vs_interp(5) z_upper = Z_HAUKSSON_LAYER_5 @@ -176,7 +176,7 @@ subroutine hauksson_model(vp,vs,utm_x_eval,utm_y_eval,z_eval,vp_final,vs_final,M vs_lower = vs_interp(6) z_lower = Z_HAUKSSON_LAYER_6 - else if(z_eval >= Z_HAUKSSON_LAYER_7) then + else if (z_eval >= Z_HAUKSSON_LAYER_7) then vp_upper = vp_interp(6) vs_upper = vs_interp(6) z_upper = Z_HAUKSSON_LAYER_6 @@ -185,7 +185,7 @@ subroutine hauksson_model(vp,vs,utm_x_eval,utm_y_eval,z_eval,vp_final,vs_final,M vs_lower = vs_interp(7) z_lower = Z_HAUKSSON_LAYER_7 -! else if(z_eval >= Z_HAUKSSON_LAYER_8) then +! else if (z_eval >= Z_HAUKSSON_LAYER_8) then ! vp_upper = vp_interp(7) ! vs_upper = vs_interp(7) ! z_upper = Z_HAUKSSON_LAYER_7 @@ -195,7 +195,7 @@ subroutine hauksson_model(vp,vs,utm_x_eval,utm_y_eval,z_eval,vp_final,vs_final,M ! z_lower = Z_HAUKSSON_LAYER_8 else - if(.not. MOHO_MAP_LUPEI) then + if (.not. MOHO_MAP_LUPEI) then vp_upper = vp_interp(7) vs_upper = vs_interp(7) z_upper = Z_HAUKSSON_LAYER_7 @@ -218,7 +218,7 @@ subroutine hauksson_model(vp,vs,utm_x_eval,utm_y_eval,z_eval,vp_final,vs_final,M gamma_interp_z = (z_eval - z_lower) / (z_upper - z_lower) - if(gamma_interp_z < -0.001d0 .or. gamma_interp_z > 1.001d0) & + if (gamma_interp_z < -0.001d0 .or. gamma_interp_z > 1.001d0) & stop 'interpolation in z is incorrect in Hauksson' vp_final = vp_upper * gamma_interp_z + vp_lower * (1.-gamma_interp_z) diff --git a/utils/unused_routines/from_old_DATA/lin_model/regrid_hauksson_regular.f90 b/utils/unused_routines/from_old_DATA/lin_model/regrid_hauksson_regular.f90 index b2f410219..c287bbb07 100644 --- a/utils/unused_routines/from_old_DATA/lin_model/regrid_hauksson_regular.f90 +++ b/utils/unused_routines/from_old_DATA/lin_model/regrid_hauksson_regular.f90 @@ -38,7 +38,7 @@ program jfdkfd distmin = +100000000000.d0 do iold=1,NLINES_HAUKSSON_DENSER dist = dsqrt((utm_x_new(i,j) - utm_x_ori(iold))**2 + (utm_y_new(i,j) - utm_y_ori(iold))**2) - if(dist < distmin) then + if (dist < distmin) then ic = iold distmin = dist endif diff --git a/utils/unused_routines/from_old_DATA/lin_model/smooth_final_hauksson.f90 b/utils/unused_routines/from_old_DATA/lin_model/smooth_final_hauksson.f90 index ca6520727..50867fb27 100644 --- a/utils/unused_routines/from_old_DATA/lin_model/smooth_final_hauksson.f90 +++ b/utils/unused_routines/from_old_DATA/lin_model/smooth_final_hauksson.f90 @@ -31,10 +31,10 @@ program jfdkfd do jloop = j-NSIZE,j+NSIZE ival = iloop jval = jloop - if(ival<1) ival = 1 - if(jval<1) jval = 1 - if(ival>NGRID_NEW_HAUKSSON) ival = NGRID_NEW_HAUKSSON - if(jval>NGRID_NEW_HAUKSSON) jval = NGRID_NEW_HAUKSSON + if (ival<1) ival = 1 + if (jval<1) jval = 1 + if (ival>NGRID_NEW_HAUKSSON) ival = NGRID_NEW_HAUKSSON + if (jval>NGRID_NEW_HAUKSSON) jval = NGRID_NEW_HAUKSSON meanval = meanval + value_old(ivalue,ival,jval) enddo enddo diff --git a/utils/unused_routines/get_MPI_cutplanes_eta.f90 b/utils/unused_routines/get_MPI_cutplanes_eta.f90 index 2ec99fefd..2c67dbf5a 100644 --- a/utils/unused_routines/get_MPI_cutplanes_eta.f90 +++ b/utils/unused_routines/get_MPI_cutplanes_eta.f90 @@ -87,7 +87,7 @@ subroutine get_MPI_cutplanes_eta(myrank,prname,nspec,iMPIcut_eta,ibool, & ispecc1=0 do ispec=1,nspec - if(iMPIcut_eta(1,ispec)) then + if (iMPIcut_eta(1,ispec)) then ispecc1=ispecc1+1 @@ -97,7 +97,7 @@ subroutine get_MPI_cutplanes_eta(myrank,prname,nspec,iMPIcut_eta,ibool, & do iz=1,NGLLZ ! select point, if not already selected - if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then + if (.not. mask_ibool(ibool(ix,iy,iz,ispec))) then mask_ibool(ibool(ix,iy,iz,ispec)) = .true. npoin2D_eta = npoin2D_eta + 1 @@ -120,7 +120,7 @@ subroutine get_MPI_cutplanes_eta(myrank,prname,nspec,iMPIcut_eta,ibool, & close(10) ! compare number of surface elements detected to analytical value - if(ispecc1 /= nspec2Dtheor1 .and. ispecc1 /= nspec2Dtheor2) & + if (ispecc1 /= nspec2Dtheor1 .and. ispecc1 /= nspec2Dtheor2) & call exit_MPI(myrank,'error MPI cut-planes detection in eta=left') ! @@ -140,7 +140,7 @@ subroutine get_MPI_cutplanes_eta(myrank,prname,nspec,iMPIcut_eta,ibool, & ispecc2=0 do ispec=1,nspec - if(iMPIcut_eta(2,ispec)) then + if (iMPIcut_eta(2,ispec)) then ispecc2=ispecc2+1 @@ -150,7 +150,7 @@ subroutine get_MPI_cutplanes_eta(myrank,prname,nspec,iMPIcut_eta,ibool, & do iz=1,NGLLZ ! select point, if not already selected - if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then + if (.not. mask_ibool(ibool(ix,iy,iz,ispec))) then mask_ibool(ibool(ix,iy,iz,ispec)) = .true. npoin2D_eta = npoin2D_eta + 1 @@ -173,7 +173,7 @@ subroutine get_MPI_cutplanes_eta(myrank,prname,nspec,iMPIcut_eta,ibool, & close(10) ! compare number of surface elements detected to analytical value - if(ispecc2 /= nspec2Dtheor1 .and. ispecc2 /= nspec2Dtheor2) & + if (ispecc2 /= nspec2Dtheor1 .and. ispecc2 /= nspec2Dtheor2) & call exit_MPI(myrank,'error MPI cut-planes detection in eta=right') end subroutine get_MPI_cutplanes_eta diff --git a/utils/unused_routines/get_MPI_cutplanes_xi.f90 b/utils/unused_routines/get_MPI_cutplanes_xi.f90 index 29f53ac87..5c5e0341d 100644 --- a/utils/unused_routines/get_MPI_cutplanes_xi.f90 +++ b/utils/unused_routines/get_MPI_cutplanes_xi.f90 @@ -87,7 +87,7 @@ subroutine get_MPI_cutplanes_xi(myrank,prname,nspec,iMPIcut_xi,ibool, & ispecc1=0 do ispec=1,nspec - if(iMPIcut_xi(1,ispec)) then + if (iMPIcut_xi(1,ispec)) then ispecc1=ispecc1+1 @@ -97,7 +97,7 @@ subroutine get_MPI_cutplanes_xi(myrank,prname,nspec,iMPIcut_xi,ibool, & do iz=1,NGLLZ ! select point, if not already selected - if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then + if (.not. mask_ibool(ibool(ix,iy,iz,ispec))) then mask_ibool(ibool(ix,iy,iz,ispec)) = .true. npoin2D_xi = npoin2D_xi + 1 @@ -120,7 +120,7 @@ subroutine get_MPI_cutplanes_xi(myrank,prname,nspec,iMPIcut_xi,ibool, & close(10) ! compare number of surface elements detected to analytical value - if(ispecc1 /= nspec2Dtheor1 .and. ispecc1 /= nspec2Dtheor2) & + if (ispecc1 /= nspec2Dtheor1 .and. ispecc1 /= nspec2Dtheor2) & call exit_MPI(myrank,'error MPI cut-planes detection in xi=left') ! @@ -140,7 +140,7 @@ subroutine get_MPI_cutplanes_xi(myrank,prname,nspec,iMPIcut_xi,ibool, & ispecc2=0 do ispec=1,nspec - if(iMPIcut_xi(2,ispec)) then + if (iMPIcut_xi(2,ispec)) then ispecc2=ispecc2+1 @@ -150,7 +150,7 @@ subroutine get_MPI_cutplanes_xi(myrank,prname,nspec,iMPIcut_xi,ibool, & do iz=1,NGLLZ ! select point, if not already selected - if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then + if (.not. mask_ibool(ibool(ix,iy,iz,ispec))) then mask_ibool(ibool(ix,iy,iz,ispec)) = .true. npoin2D_xi = npoin2D_xi + 1 @@ -173,7 +173,7 @@ subroutine get_MPI_cutplanes_xi(myrank,prname,nspec,iMPIcut_xi,ibool, & close(10) ! compare number of surface elements detected to analytical value - if(ispecc2 /= nspec2Dtheor1 .and. ispecc2 /= nspec2Dtheor2) & + if (ispecc2 /= nspec2Dtheor1 .and. ispecc2 /= nspec2Dtheor2) & call exit_MPI(myrank,'error MPI cut-planes detection in xi=right') end subroutine get_MPI_cutplanes_xi diff --git a/utils/unused_routines/get_absorb.f90 b/utils/unused_routines/get_absorb.f90 index 9fb4a7274..4361b3d8d 100644 --- a/utils/unused_routines/get_absorb.f90 +++ b/utils/unused_routines/get_absorb.f90 @@ -64,7 +64,7 @@ subroutine get_absorb(myrank,prname,iboun,nspec, & ! determine if the element falls on an absorbing boundary - if(iboun(1,ispecg)) then + if (iboun(1,ispecg)) then ! on boundary 1: xmin ispecb1=ispecb1+1 @@ -75,10 +75,10 @@ subroutine get_absorb(myrank,prname,iboun,nspec, & ! check for ovelap with other boundaries nkmin_xi(1,ispecb1)=1 - if(iboun(5,ispecg)) nkmin_xi(1,ispecb1)=2 + if (iboun(5,ispecg)) nkmin_xi(1,ispecb1)=2 endif - if(iboun(2,ispecg)) then + if (iboun(2,ispecg)) then ! on boundary 2: xmax ispecb2=ispecb2+1 @@ -89,44 +89,44 @@ subroutine get_absorb(myrank,prname,iboun,nspec, & ! check for ovelap with other boundaries nkmin_xi(2,ispecb2)=1 - if(iboun(5,ispecg)) nkmin_xi(2,ispecb2)=2 + if (iboun(5,ispecg)) nkmin_xi(2,ispecb2)=2 endif - if(iboun(3,ispecg)) then + if (iboun(3,ispecg)) then ! on boundary 3: ymin ispecb3=ispecb3+1 ! check for ovelap with other boundaries nimin(1,ispecb3)=1 - if(iboun(1,ispecg)) nimin(1,ispecb3)=2 + if (iboun(1,ispecg)) nimin(1,ispecb3)=2 nimax(1,ispecb3)=NGLLX - if(iboun(2,ispecg)) nimax(1,ispecb3)=NGLLX-1 + if (iboun(2,ispecg)) nimax(1,ispecb3)=NGLLX-1 nkmin_eta(1,ispecb3)=1 - if(iboun(5,ispecg)) nkmin_eta(1,ispecb3)=2 + if (iboun(5,ispecg)) nkmin_eta(1,ispecb3)=2 endif - if(iboun(4,ispecg)) then + if (iboun(4,ispecg)) then ! on boundary 4: ymax ispecb4=ispecb4+1 ! check for ovelap with other boundaries nimin(2,ispecb4)=1 - if(iboun(1,ispecg)) nimin(2,ispecb4)=2 + if (iboun(1,ispecg)) nimin(2,ispecb4)=2 nimax(2,ispecb4)=NGLLX - if(iboun(2,ispecg)) nimax(2,ispecb4)=NGLLX-1 + if (iboun(2,ispecg)) nimax(2,ispecb4)=NGLLX-1 nkmin_eta(2,ispecb4)=1 - if(iboun(5,ispecg)) nkmin_eta(2,ispecb4)=2 + if (iboun(5,ispecg)) nkmin_eta(2,ispecb4)=2 endif ! on boundary 5: bottom - if(iboun(5,ispecg)) ispecb5=ispecb5+1 + if (iboun(5,ispecg)) ispecb5=ispecb5+1 enddo ! check theoretical value of elements at the bottom - if(ispecb5 /= NSPEC2D_BOTTOM) & + if (ispecb5 /= NSPEC2D_BOTTOM) & call exit_MPI(myrank,'ispecb5 should equal NSPEC2D_BOTTOM in absorbing boundary detection') ! IMPROVE save these temporary arrays for the solver for Stacey conditions @@ -199,7 +199,7 @@ subroutine get_absorb_ext_mesh(myrank,iboun,nspec, & ! determine if the element falls on an absorbing boundary - if(iboun(1,ispecg)) then + if (iboun(1,ispecg)) then ! on boundary 1: xmin ispecb1=ispecb1+1 @@ -210,10 +210,10 @@ subroutine get_absorb_ext_mesh(myrank,iboun,nspec, & ! check for ovelap with other boundaries nkmin_xi(1,ispecb1)=1 - if(iboun(5,ispecg)) nkmin_xi(1,ispecb1)=2 + if (iboun(5,ispecg)) nkmin_xi(1,ispecb1)=2 endif - if(iboun(2,ispecg)) then + if (iboun(2,ispecg)) then ! on boundary 2: xmax ispecb2=ispecb2+1 @@ -224,44 +224,44 @@ subroutine get_absorb_ext_mesh(myrank,iboun,nspec, & ! check for ovelap with other boundaries nkmin_xi(2,ispecb2)=1 - if(iboun(5,ispecg)) nkmin_xi(2,ispecb2)=2 + if (iboun(5,ispecg)) nkmin_xi(2,ispecb2)=2 endif - if(iboun(3,ispecg)) then + if (iboun(3,ispecg)) then ! on boundary 3: ymin ispecb3=ispecb3+1 ! check for ovelap with other boundaries nimin(1,ispecb3)=1 - if(iboun(1,ispecg)) nimin(1,ispecb3)=2 + if (iboun(1,ispecg)) nimin(1,ispecb3)=2 nimax(1,ispecb3)=NGLLX - if(iboun(2,ispecg)) nimax(1,ispecb3)=NGLLX-1 + if (iboun(2,ispecg)) nimax(1,ispecb3)=NGLLX-1 nkmin_eta(1,ispecb3)=1 - if(iboun(5,ispecg)) nkmin_eta(1,ispecb3)=2 + if (iboun(5,ispecg)) nkmin_eta(1,ispecb3)=2 endif - if(iboun(4,ispecg)) then + if (iboun(4,ispecg)) then ! on boundary 4: ymax ispecb4=ispecb4+1 ! check for ovelap with other boundaries nimin(2,ispecb4)=1 - if(iboun(1,ispecg)) nimin(2,ispecb4)=2 + if (iboun(1,ispecg)) nimin(2,ispecb4)=2 nimax(2,ispecb4)=NGLLX - if(iboun(2,ispecg)) nimax(2,ispecb4)=NGLLX-1 + if (iboun(2,ispecg)) nimax(2,ispecb4)=NGLLX-1 nkmin_eta(2,ispecb4)=1 - if(iboun(5,ispecg)) nkmin_eta(2,ispecb4)=2 + if (iboun(5,ispecg)) nkmin_eta(2,ispecb4)=2 endif ! on boundary 5: bottom - if(iboun(5,ispecg)) ispecb5=ispecb5+1 + if (iboun(5,ispecg)) ispecb5=ispecb5+1 enddo ! check theoretical value of elements at the bottom - if(ispecb5 /= NSPEC2D_BOTTOM) & + if (ispecb5 /= NSPEC2D_BOTTOM) & call exit_MPI(myrank,'ispecb5 should equal NSPEC2D_BOTTOM in absorbing boundary detection') end subroutine get_absorb_ext_mesh diff --git a/utils/unused_routines/get_flags_boundaries.f90 b/utils/unused_routines/get_flags_boundaries.f90 index f10feee42..8e0708f44 100644 --- a/utils/unused_routines/get_flags_boundaries.f90 +++ b/utils/unused_routines/get_flags_boundaries.f90 @@ -90,26 +90,26 @@ subroutine get_flags_boundaries(nspec,iproc_xi,iproc_eta,ispec,idoubling, & ! on boundary 1: x=xmin target= UTM_X_MIN + TOLERANCE_METERS - if(xelm(1)target .and. xelm(3)>target .and. xelm(6)>target .and. xelm(7)>target) iboun(2,ispec)=.true. + if (xelm(2)>target .and. xelm(3)>target .and. xelm(6)>target .and. xelm(7)>target) iboun(2,ispec)=.true. ! on boundary 3: ymin target= UTM_Y_MIN + TOLERANCE_METERS - if(yelm(1)target .and. yelm(4)>target .and. yelm(7)>target .and. yelm(8)>target) iboun(4,ispec)=.true. + if (yelm(3)>target .and. yelm(4)>target .and. yelm(7)>target .and. yelm(8)>target) iboun(4,ispec)=.true. ! on boundary 5: bottom target = Z_DEPTH_BLOCK + TOLERANCE_METERS - if(zelm(1)target .and. xelm(3)>target .and. xelm(6)>target .and. xelm(7)>target) & + if (xelm(2)>target .and. xelm(3)>target .and. xelm(6)>target .and. xelm(7)>target) & iMPIcut_xi(2,ispec)=.true. ! ******************************************************************** @@ -149,14 +149,14 @@ subroutine get_flags_boundaries(nspec,iproc_xi,iproc_eta,ispec,idoubling, & ! and add geometrical tolerance target = UTM_Y_MIN + iproc_eta*sizeslice + TOLERANCE_METERS - if(yelm(1)target .and. yelm(4)>target .and. yelm(7)>target .and. yelm(8)>target) & + if (yelm(3)>target .and. yelm(4)>target .and. yelm(7)>target .and. yelm(8)>target) & iMPIcut_eta(2,ispec)=.true. end subroutine get_flags_boundaries diff --git a/utils/unused_routines/hauksson_model.f90 b/utils/unused_routines/hauksson_model.f90 index 013bbe4d0..6a9acc22a 100644 --- a/utils/unused_routines/hauksson_model.f90 +++ b/utils/unused_routines/hauksson_model.f90 @@ -55,8 +55,8 @@ subroutine hauksson_model(vp,vs,utm_x_eval,utm_y_eval,z_eval,vp_final,vs_final,M utm_y_eval_copy = utm_y_eval ! make sure we stay inside Hauksson's grid - if(utm_x_eval_copy < UTM_X_ORIG_HAUKSSON) utm_x_eval_copy = UTM_X_ORIG_HAUKSSON - if(utm_y_eval_copy < UTM_Y_ORIG_HAUKSSON) utm_y_eval_copy = UTM_Y_ORIG_HAUKSSON + if (utm_x_eval_copy < UTM_X_ORIG_HAUKSSON) utm_x_eval_copy = UTM_X_ORIG_HAUKSSON + if (utm_y_eval_copy < UTM_Y_ORIG_HAUKSSON) utm_y_eval_copy = UTM_Y_ORIG_HAUKSSON ! determine spacing and cell for linear interpolation spacing_x = (utm_x_eval_copy - UTM_X_ORIG_HAUKSSON) / SPACING_UTM_X_HAUKSSON @@ -69,28 +69,28 @@ subroutine hauksson_model(vp,vs,utm_x_eval,utm_y_eval,z_eval,vp_final,vs_final,M gamma_interp_y = spacing_y - int(spacing_y) ! suppress edge effects for points outside of Hauksson's model - if(icell_interp_x < 1) then + if (icell_interp_x < 1) then icell_interp_x = 1 gamma_interp_x = 0.d0 endif - if(icell_interp_x > NGRID_NEW_HAUKSSON-1) then + if (icell_interp_x > NGRID_NEW_HAUKSSON-1) then icell_interp_x = NGRID_NEW_HAUKSSON-1 gamma_interp_x = 1.d0 endif - if(icell_interp_y < 1) then + if (icell_interp_y < 1) then icell_interp_y = 1 gamma_interp_y = 0.d0 endif - if(icell_interp_y > NGRID_NEW_HAUKSSON-1) then + if (icell_interp_y > NGRID_NEW_HAUKSSON-1) then icell_interp_y = NGRID_NEW_HAUKSSON-1 gamma_interp_y = 1.d0 endif ! make sure interpolation makes sense - if(gamma_interp_x < -0.001d0 .or. gamma_interp_x > 1.001d0) & + if (gamma_interp_x < -0.001d0 .or. gamma_interp_x > 1.001d0) & stop 'interpolation in x is incorrect in Hauksson' - if(gamma_interp_y < -0.001d0 .or. gamma_interp_y > 1.001d0) & + if (gamma_interp_y < -0.001d0 .or. gamma_interp_y > 1.001d0) & stop 'interpolation in y is incorrect in Hauksson' ! interpolate Hauksson's model at right location using bilinear interpolation @@ -121,17 +121,17 @@ subroutine hauksson_model(vp,vs,utm_x_eval,utm_y_eval,z_eval,vp_final,vs_final,M enddo ! choose right values depending on depth of target point - if(z_eval >= Z_HAUKSSON_LAYER_1) then + if (z_eval >= Z_HAUKSSON_LAYER_1) then vp_final = vp_interp(1) vs_final = vs_interp(1) return - else if(z_eval <= Z_HAUKSSON_LAYER_9) then + else if (z_eval <= Z_HAUKSSON_LAYER_9) then vp_final = vp_interp(9) vs_final = vs_interp(9) return - else if(z_eval >= Z_HAUKSSON_LAYER_2) then + else if (z_eval >= Z_HAUKSSON_LAYER_2) then vp_upper = vp_interp(1) vs_upper = vs_interp(1) z_upper = Z_HAUKSSON_LAYER_1 @@ -140,7 +140,7 @@ subroutine hauksson_model(vp,vs,utm_x_eval,utm_y_eval,z_eval,vp_final,vs_final,M vs_lower = vs_interp(2) z_lower = Z_HAUKSSON_LAYER_2 - else if(z_eval >= Z_HAUKSSON_LAYER_3) then + else if (z_eval >= Z_HAUKSSON_LAYER_3) then vp_upper = vp_interp(2) vs_upper = vs_interp(2) z_upper = Z_HAUKSSON_LAYER_2 @@ -149,7 +149,7 @@ subroutine hauksson_model(vp,vs,utm_x_eval,utm_y_eval,z_eval,vp_final,vs_final,M vs_lower = vs_interp(3) z_lower = Z_HAUKSSON_LAYER_3 - else if(z_eval >= Z_HAUKSSON_LAYER_4) then + else if (z_eval >= Z_HAUKSSON_LAYER_4) then vp_upper = vp_interp(3) vs_upper = vs_interp(3) z_upper = Z_HAUKSSON_LAYER_3 @@ -158,7 +158,7 @@ subroutine hauksson_model(vp,vs,utm_x_eval,utm_y_eval,z_eval,vp_final,vs_final,M vs_lower = vs_interp(4) z_lower = Z_HAUKSSON_LAYER_4 - else if(z_eval >= Z_HAUKSSON_LAYER_5) then + else if (z_eval >= Z_HAUKSSON_LAYER_5) then vp_upper = vp_interp(4) vs_upper = vs_interp(4) z_upper = Z_HAUKSSON_LAYER_4 @@ -167,7 +167,7 @@ subroutine hauksson_model(vp,vs,utm_x_eval,utm_y_eval,z_eval,vp_final,vs_final,M vs_lower = vs_interp(5) z_lower = Z_HAUKSSON_LAYER_5 - else if(z_eval >= Z_HAUKSSON_LAYER_6) then + else if (z_eval >= Z_HAUKSSON_LAYER_6) then vp_upper = vp_interp(5) vs_upper = vs_interp(5) z_upper = Z_HAUKSSON_LAYER_5 @@ -176,7 +176,7 @@ subroutine hauksson_model(vp,vs,utm_x_eval,utm_y_eval,z_eval,vp_final,vs_final,M vs_lower = vs_interp(6) z_lower = Z_HAUKSSON_LAYER_6 - else if(z_eval >= Z_HAUKSSON_LAYER_7) then + else if (z_eval >= Z_HAUKSSON_LAYER_7) then vp_upper = vp_interp(6) vs_upper = vs_interp(6) z_upper = Z_HAUKSSON_LAYER_6 @@ -185,7 +185,7 @@ subroutine hauksson_model(vp,vs,utm_x_eval,utm_y_eval,z_eval,vp_final,vs_final,M vs_lower = vs_interp(7) z_lower = Z_HAUKSSON_LAYER_7 - else if(z_eval >= Z_HAUKSSON_LAYER_8) then + else if (z_eval >= Z_HAUKSSON_LAYER_8) then vp_upper = vp_interp(7) vs_upper = vs_interp(7) z_upper = Z_HAUKSSON_LAYER_7 @@ -195,7 +195,7 @@ subroutine hauksson_model(vp,vs,utm_x_eval,utm_y_eval,z_eval,vp_final,vs_final,M z_lower = Z_HAUKSSON_LAYER_8 else - if(.not. MOHO_MAP_LUPEI) then + if (.not. MOHO_MAP_LUPEI) then vp_upper = vp_interp(8) vs_upper = vs_interp(8) z_upper = Z_HAUKSSON_LAYER_8 @@ -218,7 +218,7 @@ subroutine hauksson_model(vp,vs,utm_x_eval,utm_y_eval,z_eval,vp_final,vs_final,M gamma_interp_z = (z_eval - z_lower) / (z_upper - z_lower) - if(gamma_interp_z < -0.001d0 .or. gamma_interp_z > 1.001d0) & + if (gamma_interp_z < -0.001d0 .or. gamma_interp_z > 1.001d0) & stop 'interpolation in z is incorrect in Hauksson' vp_final = vp_upper * gamma_interp_z + vp_lower * (1.-gamma_interp_z) diff --git a/utils/unused_routines/interpolate_gocad_block_HR.f90 b/utils/unused_routines/interpolate_gocad_block_HR.f90 index c7c713101..0707e6303 100644 --- a/utils/unused_routines/interpolate_gocad_block_HR.f90 +++ b/utils/unused_routines/interpolate_gocad_block_HR.f90 @@ -46,14 +46,14 @@ subroutine interpolate_gocad_block_HR(vp_block_gocad_HR,vp_block_gocad_MR, & ! this block is smaller than the grid, therefore just exit ! if the target point is outside of the block - if(ix < 0 .or. ix > NX_GOCAD_HR-2 .or. iy < 0 .or. iy > NY_GOCAD_HR-2) return + if (ix < 0 .or. ix > NX_GOCAD_HR-2 .or. iy < 0 .or. iy > NY_GOCAD_HR-2) return ! suppress edge effects in vertical direction - if(iz < 0) then + if (iz < 0) then iz = 0 gamma_interp_z = 0.d0 endif - if(iz > NZ_GOCAD_HR-2) then + if (iz > NZ_GOCAD_HR-2) then iz = NZ_GOCAD_HR-2 gamma_interp_z = 1.d0 endif @@ -72,7 +72,7 @@ subroutine interpolate_gocad_block_HR(vp_block_gocad_HR,vp_block_gocad_MR, & ! check if element is defined (i.e. is in the sediments in Voxet) ! do nothing if element is undefined ! a P-velocity of 20 km/s is used to indicate fictitious elements - if(v1 < 19000. .and. v2 < 19000. .and. & + if (v1 < 19000. .and. v2 < 19000. .and. & v3 < 19000. .and. v4 < 19000. .and. & v5 < 19000. .and. v6 < 19000. .and. & v7 < 19000. .and. v8 < 19000.) then @@ -92,15 +92,15 @@ subroutine interpolate_gocad_block_HR(vp_block_gocad_HR,vp_block_gocad_MR, & v8*(1.-gamma_interp_x)*gamma_interp_y*gamma_interp_z ! impose minimum velocity if needed - if(IMPOSE_MINIMUM_VP_GOCAD .and. vp_final < VP_MIN_GOCAD) vp_final = VP_MIN_GOCAD + if (IMPOSE_MINIMUM_VP_GOCAD .and. vp_final < VP_MIN_GOCAD) vp_final = VP_MIN_GOCAD ! taper edges to make smooth transition between MR and HR blocks ! get value from edge of medium-resolution block ! then use linear interpolation from edge of the model - if(TAPER_GOCAD_TRANSITIONS) then + if (TAPER_GOCAD_TRANSITIONS) then ! x = xmin - if(utm_x_eval < ORIG_X_GOCAD_HR + THICKNESS_TAPER_BLOCK_HR) then + if (utm_x_eval < ORIG_X_GOCAD_HR + THICKNESS_TAPER_BLOCK_HR) then gamma_interp_x = (utm_x_eval - ORIG_X_GOCAD_HR) / THICKNESS_TAPER_BLOCK_HR call interpolate_gocad_block_MR(vp_block_gocad_MR, & ORIG_X_GOCAD_HR,utm_y_eval,z_eval,rho_ref_MR,vp_ref_MR,vs_ref_MR,dummy_flag, & @@ -110,7 +110,7 @@ subroutine interpolate_gocad_block_HR(vp_block_gocad_HR,vp_block_gocad_MR, & vp_final = vp_ref_MR * (1. - gamma_interp_x) + vp_final * gamma_interp_x ! x = xmax - else if(utm_x_eval > END_X_GOCAD_HR - THICKNESS_TAPER_BLOCK_HR) then + else if (utm_x_eval > END_X_GOCAD_HR - THICKNESS_TAPER_BLOCK_HR) then gamma_interp_x = (utm_x_eval - (END_X_GOCAD_HR - THICKNESS_TAPER_BLOCK_HR)) / THICKNESS_TAPER_BLOCK_HR call interpolate_gocad_block_MR(vp_block_gocad_MR, & END_X_GOCAD_HR,utm_y_eval,z_eval,rho_ref_MR,vp_ref_MR,vs_ref_MR,dummy_flag, & @@ -120,7 +120,7 @@ subroutine interpolate_gocad_block_HR(vp_block_gocad_HR,vp_block_gocad_MR, & vp_final = vp_ref_MR * gamma_interp_x + vp_final * (1. - gamma_interp_x) ! y = ymin - else if(utm_y_eval < ORIG_Y_GOCAD_HR + THICKNESS_TAPER_BLOCK_HR) then + else if (utm_y_eval < ORIG_Y_GOCAD_HR + THICKNESS_TAPER_BLOCK_HR) then gamma_interp_y = (utm_y_eval - ORIG_Y_GOCAD_HR) / THICKNESS_TAPER_BLOCK_HR call interpolate_gocad_block_MR(vp_block_gocad_MR, & utm_x_eval,ORIG_Y_GOCAD_HR,z_eval,rho_ref_MR,vp_ref_MR,vs_ref_MR,dummy_flag, & @@ -130,7 +130,7 @@ subroutine interpolate_gocad_block_HR(vp_block_gocad_HR,vp_block_gocad_MR, & vp_final = vp_ref_MR * (1. - gamma_interp_y) + vp_final * gamma_interp_y ! y = ymax - else if(utm_y_eval > END_Y_GOCAD_HR - THICKNESS_TAPER_BLOCK_HR) then + else if (utm_y_eval > END_Y_GOCAD_HR - THICKNESS_TAPER_BLOCK_HR) then gamma_interp_y = (utm_y_eval - (END_Y_GOCAD_HR - THICKNESS_TAPER_BLOCK_HR)) / THICKNESS_TAPER_BLOCK_HR call interpolate_gocad_block_MR(vp_block_gocad_MR, & utm_x_eval,END_Y_GOCAD_HR,z_eval,rho_ref_MR,vp_ref_MR,vs_ref_MR,dummy_flag, & @@ -149,8 +149,8 @@ subroutine interpolate_gocad_block_HR(vp_block_gocad_HR,vp_block_gocad_MR, & (z_eval - (-8500.d0)) / (0.d0 - (-8500.d0)) ! make sure ratio remains in interval - if(vp_vs_ratio < VP_VS_RATIO_GOCAD_BOTTOM) vp_vs_ratio = VP_VS_RATIO_GOCAD_BOTTOM - if(vp_vs_ratio > VP_VS_RATIO_GOCAD_TOP) vp_vs_ratio = VP_VS_RATIO_GOCAD_TOP + if (vp_vs_ratio < VP_VS_RATIO_GOCAD_BOTTOM) vp_vs_ratio = VP_VS_RATIO_GOCAD_BOTTOM + if (vp_vs_ratio > VP_VS_RATIO_GOCAD_TOP) vp_vs_ratio = VP_VS_RATIO_GOCAD_TOP vs_final = vp_final / vp_vs_ratio call compute_rho_estimate(rho_final,vp_final) diff --git a/utils/unused_routines/interpolate_gocad_block_MR.f90 b/utils/unused_routines/interpolate_gocad_block_MR.f90 index 848713b83..c86c9b6b9 100644 --- a/utils/unused_routines/interpolate_gocad_block_MR.f90 +++ b/utils/unused_routines/interpolate_gocad_block_MR.f90 @@ -44,29 +44,29 @@ subroutine interpolate_gocad_block_MR(vp_block_gocad_MR, & gamma_interp_z = spacing_z - dble(iz) ! suppress edge effects for points outside of Gocad model - if(ix < 0) then + if (ix < 0) then ix = 0 gamma_interp_x = 0.d0 endif - if(ix > NX_GOCAD_MR-2) then + if (ix > NX_GOCAD_MR-2) then ix = NX_GOCAD_MR-2 gamma_interp_x = 1.d0 endif - if(iy < 0) then + if (iy < 0) then iy = 0 gamma_interp_y = 0.d0 endif - if(iy > NY_GOCAD_MR-2) then + if (iy > NY_GOCAD_MR-2) then iy = NY_GOCAD_MR-2 gamma_interp_y = 1.d0 endif - if(iz < 0) then + if (iz < 0) then iz = 0 gamma_interp_z = 0.d0 endif - if(iz > NZ_GOCAD_MR-2) then + if (iz > NZ_GOCAD_MR-2) then iz = NZ_GOCAD_MR-2 gamma_interp_z = 1.d0 endif @@ -85,7 +85,7 @@ subroutine interpolate_gocad_block_MR(vp_block_gocad_MR, & ! check if element is defined (i.e. is in the sediments in Voxet) ! do nothing if element is undefined ! a P-velocity of 20 km/s is used to indicate fictitious elements - if(v1 < 19000. .and. v2 < 19000. .and. & + if (v1 < 19000. .and. v2 < 19000. .and. & v3 < 19000. .and. v4 < 19000. .and. & v5 < 19000. .and. v6 < 19000. .and. & v7 < 19000. .and. v8 < 19000.) then @@ -105,19 +105,19 @@ subroutine interpolate_gocad_block_MR(vp_block_gocad_MR, & v8*(1.-gamma_interp_x)*gamma_interp_y*gamma_interp_z ! impose minimum velocity if needed - if(IMPOSE_MINIMUM_VP_GOCAD .and. vp_final < VP_MIN_GOCAD) vp_final = VP_MIN_GOCAD + if (IMPOSE_MINIMUM_VP_GOCAD .and. vp_final < VP_MIN_GOCAD) vp_final = VP_MIN_GOCAD ! taper edges to make smooth transition between Hauksson and MR blocks ! get value from edge of medium-resolution block ! then use linear interpolation from edge of the model - if(TAPER_GOCAD_TRANSITIONS) then + if (TAPER_GOCAD_TRANSITIONS) then ! x = xmin - if(utm_x_eval < ORIG_X_GOCAD_MR + THICKNESS_TAPER_BLOCK_MR) then + if (utm_x_eval < ORIG_X_GOCAD_MR + THICKNESS_TAPER_BLOCK_MR) then xmesh = ORIG_X_GOCAD_MR ymesh = utm_y_eval zmesh = z_eval - if(HAUKSSON_REGIONAL_MODEL) then + if (HAUKSSON_REGIONAL_MODEL) then call hauksson_model(vp_hauksson,vs_hauksson,xmesh,ymesh,zmesh,vp_ref_hauksson,vs_dummy, MOHO_MAP_LUPEI) else call socal_model(doubling_index,rho_dummy,vp_ref_hauksson,vs_dummy) @@ -126,11 +126,11 @@ subroutine interpolate_gocad_block_MR(vp_block_gocad_MR, & vp_final = vp_ref_hauksson * (1. - gamma_interp_x) + vp_final * gamma_interp_x ! x = xmax - else if(utm_x_eval > END_X_GOCAD_MR - THICKNESS_TAPER_BLOCK_MR) then + else if (utm_x_eval > END_X_GOCAD_MR - THICKNESS_TAPER_BLOCK_MR) then xmesh = END_X_GOCAD_MR ymesh = utm_y_eval zmesh = z_eval - if(HAUKSSON_REGIONAL_MODEL) then + if (HAUKSSON_REGIONAL_MODEL) then call hauksson_model(vp_hauksson,vs_hauksson,xmesh,ymesh,zmesh,vp_ref_hauksson,vs_dummy, MOHO_MAP_LUPEI) else call socal_model(doubling_index,rho_dummy,vp_ref_hauksson,vs_dummy) @@ -139,11 +139,11 @@ subroutine interpolate_gocad_block_MR(vp_block_gocad_MR, & vp_final = vp_ref_hauksson * gamma_interp_x + vp_final * (1. - gamma_interp_x) ! y = ymin - else if(utm_y_eval < ORIG_Y_GOCAD_MR + THICKNESS_TAPER_BLOCK_MR) then + else if (utm_y_eval < ORIG_Y_GOCAD_MR + THICKNESS_TAPER_BLOCK_MR) then xmesh = utm_x_eval ymesh = ORIG_Y_GOCAD_MR zmesh = z_eval - if(HAUKSSON_REGIONAL_MODEL) then + if (HAUKSSON_REGIONAL_MODEL) then call hauksson_model(vp_hauksson,vs_hauksson,xmesh,ymesh,zmesh,vp_ref_hauksson,vs_dummy, MOHO_MAP_LUPEI) else call socal_model(doubling_index,rho_dummy,vp_ref_hauksson,vs_dummy) @@ -152,11 +152,11 @@ subroutine interpolate_gocad_block_MR(vp_block_gocad_MR, & vp_final = vp_ref_hauksson * (1. - gamma_interp_y) + vp_final * gamma_interp_y ! y = ymax - else if(utm_y_eval > END_Y_GOCAD_MR - THICKNESS_TAPER_BLOCK_MR) then + else if (utm_y_eval > END_Y_GOCAD_MR - THICKNESS_TAPER_BLOCK_MR) then xmesh = utm_x_eval ymesh = END_Y_GOCAD_MR zmesh = z_eval - if(HAUKSSON_REGIONAL_MODEL) then + if (HAUKSSON_REGIONAL_MODEL) then call hauksson_model(vp_hauksson,vs_hauksson,xmesh,ymesh,zmesh,vp_ref_hauksson,vs_dummy, MOHO_MAP_LUPEI) else call socal_model(doubling_index,rho_dummy,vp_ref_hauksson,vs_dummy) @@ -174,8 +174,8 @@ subroutine interpolate_gocad_block_MR(vp_block_gocad_MR, & (z_eval - (-8500.d0)) / (0.d0 - (-8500.d0)) ! make sure ratio remains in interval - if(vp_vs_ratio < VP_VS_RATIO_GOCAD_BOTTOM) vp_vs_ratio = VP_VS_RATIO_GOCAD_BOTTOM - if(vp_vs_ratio > VP_VS_RATIO_GOCAD_TOP) vp_vs_ratio = VP_VS_RATIO_GOCAD_TOP + if (vp_vs_ratio < VP_VS_RATIO_GOCAD_BOTTOM) vp_vs_ratio = VP_VS_RATIO_GOCAD_BOTTOM + if (vp_vs_ratio > VP_VS_RATIO_GOCAD_TOP) vp_vs_ratio = VP_VS_RATIO_GOCAD_TOP vs_final = vp_final / vp_vs_ratio call compute_rho_estimate(rho_final,vp_final) diff --git a/utils/unused_routines/mesh_vertical.f90 b/utils/unused_routines/mesh_vertical.f90 index 2e003f199..97a4ca759 100644 --- a/utils/unused_routines/mesh_vertical.f90 +++ b/utils/unused_routines/mesh_vertical.f90 @@ -58,7 +58,7 @@ subroutine mesh_vertical(myrank,rn,NER,NER_BOTTOM_MOHO,NER_MOHO_16, & enddo ! do not use d16km when Moho map is honored - if(MOHO_MAP_LUPEI) then + if (MOHO_MAP_LUPEI) then ! !--- Moho to modified basement surface @@ -110,11 +110,11 @@ subroutine mesh_vertical(myrank,rn,NER,NER_BOTTOM_MOHO,NER_MOHO_16, & rn(:) = rn(:) / (Z_SURFACE-Z_DEPTH_BLOCK) ! check that the mesh that has been generated is correct - if(npr /= 2*NER) call exit_MPI(myrank,'incorrect intervals for model') + if (npr /= 2*NER) call exit_MPI(myrank,'incorrect intervals for model') ! check that vertical spacing makes sense do ir=0,2*NER-1 - if(rn(ir+1) < rn(ir)) call exit_MPI(myrank,'incorrect vertical spacing for model') + if (rn(ir+1) < rn(ir)) call exit_MPI(myrank,'incorrect vertical spacing for model') enddo end subroutine mesh_vertical diff --git a/utils/unused_routines/model_interface_bedrock.f90 b/utils/unused_routines/model_interface_bedrock.f90 index 72627a4b3..2e76a65b4 100644 --- a/utils/unused_routines/model_interface_bedrock.f90 +++ b/utils/unused_routines/model_interface_bedrock.f90 @@ -60,7 +60,7 @@ ! ! allocate(ibedrock(NX_TOPO_ANT,NY_TOPO_ANT)) -! if(myrank == 0) then +! if (myrank == 0) then ! call read_bedrock_file(ibedrock) ! ! write(IMAIN,*) ! ! write(IMAIN,*) 'regional bedrock file read ranges in m from ',minval(ibedrock),' to ',maxval(ibedrock) @@ -141,14 +141,14 @@ ! zmesh = zstore(2,2,2,ispec) -! ! if(doubling_index == IFLAG_ONE_LAYER_TOPOGRAPHY) then -! if(any(ibelm_top == ispec)) then +! ! if (doubling_index == IFLAG_ONE_LAYER_TOPOGRAPHY) then +! if (any(ibelm_top == ispec)) then ! doubling_value_found_for_Piero = IFLAG_ONE_LAYER_TOPOGRAPHY -! else if(zmesh < Z_23p4km) then +! else if (zmesh < Z_23p4km) then ! doubling_value_found_for_Piero = IFLAG_MANTLE_BELOW_23p4km -! else if(zmesh < Z_14km) then +! else if (zmesh < Z_14km) then ! doubling_value_found_for_Piero = IFLAG_14km_to_23p4km ! else @@ -161,7 +161,7 @@ ! do i = 1, NGLLX -! if(idoubling(ispec) == IFLAG_ONE_LAYER_TOPOGRAPHY .or. & +! if (idoubling(ispec) == IFLAG_ONE_LAYER_TOPOGRAPHY .or. & ! idoubling(ispec) == IFLAG_BEDROCK_down_to_14km) then ! ! since we have suppressed UTM projection for Piero Basini, UTMx is the same as long @@ -174,10 +174,10 @@ ! icornerlat = int((lat - ORIG_LAT_TOPO) / DEGREES_PER_CELL_TOPO) + 1 ! ! avoid edge effects and extend with identical point if outside model -! if(icornerlong < 1) icornerlong = 1 -! if(icornerlong > NX_TOPO-1) icornerlong = NX_TOPO-1 -! if(icornerlat < 1) icornerlat = 1 -! if(icornerlat > NY_TOPO-1) icornerlat = NY_TOPO-1 +! if (icornerlong < 1) icornerlong = 1 +! if (icornerlong > NX_TOPO-1) icornerlong = NX_TOPO-1 +! if (icornerlat < 1) icornerlat = 1 +! if (icornerlat > NY_TOPO-1) icornerlat = NY_TOPO-1 ! ! compute coordinates of corner ! long_corner = ORIG_LONG_TOPO + (icornerlong-1)*DEGREES_PER_CELL_TOPO @@ -188,10 +188,10 @@ ! ratio_eta = (lat - lat_corner) / DEGREES_PER_CELL_TOPO ! ! avoid edge effects -! if(ratio_xi < 0.) ratio_xi = 0. -! if(ratio_xi > 1.) ratio_xi = 1. -! if(ratio_eta < 0.) ratio_eta = 0. -! if(ratio_eta > 1.) ratio_eta = 1. +! if (ratio_xi < 0.) ratio_xi = 0. +! if (ratio_xi > 1.) ratio_xi = 1. +! if (ratio_eta < 0.) ratio_eta = 0. +! if (ratio_eta > 1.) ratio_eta = 1. ! ! interpolate elevation at current point ! elevation_bedrock = & @@ -204,7 +204,7 @@ ! !! DK DK and not in the ice ! is_around_a_station = .false. ! do istation = 1,NUMBER_OF_STATIONS -! if(sqrt((long - utm_x_station(istation))**2 + (lat - utm_y_station(istation))**2) < RADIUS_TO_EXCLUDE) then +! if (sqrt((long - utm_x_station(istation))**2 + (lat - utm_y_station(istation))**2) < RADIUS_TO_EXCLUDE) then ! is_around_a_station = .true. ! exit ! endif @@ -213,7 +213,7 @@ ! ! define elastic parameters in the model ! ! we are above the bedrock interface i.e. in the ice, and not too close to a station -! if(zmesh >= elevation_bedrock .and. .not. is_around_a_station) then +! if (zmesh >= elevation_bedrock .and. .not. is_around_a_station) then ! vp = 3800.d0 ! vs = 1900.d0 ! rho = 900.d0 @@ -227,13 +227,13 @@ ! qmu_attenuation_store(i,j,k,ispec) = 9000.0 ! IATTENUATION_BEDROCK ! endif -! else if(idoubling(ispec) == IFLAG_14km_to_23p4km) then +! else if (idoubling(ispec) == IFLAG_14km_to_23p4km) then ! vp = 6800.d0 ! vs = 3900.d0 ! rho = 2900.d0 ! qmu_attenuation_store(i,j,k,ispec) = 9000.0 ! IATTENUATION_BEDROCK -! else if(idoubling(ispec) == IFLAG_MANTLE_BELOW_23p4km) then +! else if (idoubling(ispec) == IFLAG_MANTLE_BELOW_23p4km) then ! vp = 8100.d0 ! vs = 4480.d0 ! rho = 3380.d0 @@ -242,7 +242,7 @@ ! endif ! !pll 8/06 -! if(CUSTOM_REAL == SIZE_REAL) then +! if (CUSTOM_REAL == SIZE_REAL) then ! rhostore(i,j,k,ispec) = sngl(rho) ! vpstore(i,j,k,ispec) = sngl(vp) ! vsstore(i,j,k,ispec) = sngl(vs) @@ -340,10 +340,10 @@ ! icornerlat = int((lat - ORIG_LAT_TOPO_ANT) / DEGREES_PER_CELL_TOPO_ANT) + 1 ! ! avoid edge effects and extend with identical point if outside model -! if(icornerlong < 1) icornerlong = 1 -! if(icornerlong > NX_TOPO_ANT-1) icornerlong = NX_TOPO_ANT-1 -! if(icornerlat < 1) icornerlat = 1 -! if(icornerlat > NY_TOPO_ANT-1) icornerlat = NY_TOPO_ANT-1 +! if (icornerlong < 1) icornerlong = 1 +! if (icornerlong > NX_TOPO_ANT-1) icornerlong = NX_TOPO_ANT-1 +! if (icornerlat < 1) icornerlat = 1 +! if (icornerlat > NY_TOPO_ANT-1) icornerlat = NY_TOPO_ANT-1 ! ! compute coordinates of corner ! long_corner = ORIG_LONG_TOPO_ANT + (icornerlong-1)*DEGREES_PER_CELL_TOPO_ANT @@ -354,10 +354,10 @@ ! ratio_eta = (lat - lat_corner) / DEGREES_PER_CELL_TOPO_ANT ! ! avoid edge effects -! if(ratio_xi < 0.) ratio_xi = 0. -! if(ratio_xi > 1.) ratio_xi = 1. -! if(ratio_eta < 0.) ratio_eta = 0. -! if(ratio_eta > 1.) ratio_eta = 1. +! if (ratio_xi < 0.) ratio_xi = 0. +! if (ratio_xi > 1.) ratio_xi = 1. +! if (ratio_eta < 0.) ratio_eta = 0. +! if (ratio_eta > 1.) ratio_eta = 1. ! ! interpolate elevation at current point ! elevation_bedrock = & @@ -370,7 +370,7 @@ ! !! DK DK and not in the ice ! is_around_a_station = .false. ! do istation = 1,NUMBER_OF_STATIONS -! if(sqrt((xstore(i,j,k,ispec) - utm_x_station(istation))**2 + (ystore(i,j,k,ispec) - & +! if (sqrt((xstore(i,j,k,ispec) - utm_x_station(istation))**2 + (ystore(i,j,k,ispec) - & ! utm_y_station(istation))**2) < RADIUS_TO_EXCLUDE) then ! is_around_a_station = .true. ! exit @@ -378,7 +378,7 @@ ! enddo ! ! we are above the bedrock interface i.e. in the ice, and not too close to a station -! if(zstore(i,j,k,ispec) >= elevation_bedrock .and. .not. is_around_a_station) then +! if (zstore(i,j,k,ispec) >= elevation_bedrock .and. .not. is_around_a_station) then ! iflag = flag_above ! !qmu_attenuation_store(i,j,k,ispec) = 1.0 ! IATTENUATION_ICE ! ! we are below the bedrock interface i.e. in the bedrock, or close to a station diff --git a/utils/unused_routines/opendx_AVS/combine_AVS_DX.f90 b/utils/unused_routines/opendx_AVS/combine_AVS_DX.f90 index 51c188eb9..7ad2ad03b 100644 --- a/utils/unused_routines/opendx_AVS/combine_AVS_DX.f90 +++ b/utils/unused_routines/opendx_AVS/combine_AVS_DX.f90 @@ -143,7 +143,7 @@ program combine_AVS_DX NTSTEP_BETWEEN_OUTPUT_INFO,SUPPRESS_UTM_PROJECTION,MODEL,USE_REGULAR_MESH,SIMULATION_TYPE,SAVE_FORWARD, & NTSTEP_BETWEEN_READ_ADJSRC,NOISE_TOMOGRAPHY) - if(.not. SAVE_MESH_FILES) stop 'AVS or DX files were not saved by the mesher' + if (.not. SAVE_MESH_FILES) stop 'AVS or DX files were not saved by the mesher' ! get the base pathname for output files call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', OUTPUT_FILES_PATH(1:len_trim(OUTPUT_FILES_PATH))) @@ -161,8 +161,8 @@ program combine_AVS_DX print * print *,'enter value:' read(5,*) iformat - if(iformat<1 .or. iformat>2) stop 'exiting...' - if(iformat == 1) then + if (iformat<1 .or. iformat>2) stop 'exiting...' + if (iformat == 1) then USE_OPENDX = .true. else USE_OPENDX = .false. @@ -175,10 +175,10 @@ program combine_AVS_DX print * print *,'enter value:' read(5,*) ivalue - if(ivalue<1 .or. ivalue>2) stop 'exiting...' + if (ivalue<1 .or. ivalue>2) stop 'exiting...' ! apply scaling to topography if needed - if(ivalue == 2) then + if (ivalue == 2) then print * print *,'scaling to apply to Z to amplify topography (1. to do nothing, 0. to get flat surface):' read(5,*) zscaling @@ -195,8 +195,8 @@ program combine_AVS_DX print * print *,'enter value:' read(5,*) icolor - if(icolor<1 .or. icolor >4) stop 'exiting...' - if(icolor == 3 .and. ivalue /= 2) stop 'color by elevation of topography is for surface of model only' + if (icolor<1 .or. icolor >4) stop 'exiting...' + if (icolor == 3 .and. ivalue /= 2) stop 'color by elevation of topography is for surface of model only' print * print *,'1 = material property by doubling flag' @@ -205,7 +205,7 @@ program combine_AVS_DX print * print *,'enter value:' read(5,*) imaterial - if(imaterial < 1 .or. imaterial > 2) stop 'exiting...' + if (imaterial < 1 .or. imaterial > 2) stop 'exiting...' ! compute other parameters based upon values read call compute_parameters(NER,NEX_XI,NEX_ETA,NPROC_XI,NPROC_ETA, & @@ -224,18 +224,18 @@ program combine_AVS_DX print * print *,'enter first proc (proc numbers start at 0) = ' read(5,*) proc_p1 - if(proc_p1 < 0) proc_p1 = 0 - if(proc_p1 > NPROC-1) proc_p1 = NPROC-1 + if (proc_p1 < 0) proc_p1 = 0 + if (proc_p1 > NPROC-1) proc_p1 = NPROC-1 print *,'enter last proc (enter -1 for all procs) = ' read(5,*) proc_p2 - if(proc_p2 == -1) proc_p2 = NPROC-1 - if(proc_p2 < 0) proc_p2 = 0 - if(proc_p2 > NPROC-1) proc_p2 = NPROC-1 + if (proc_p2 == -1) proc_p2 = NPROC-1 + if (proc_p2 < 0) proc_p2 = 0 + if (proc_p2 > NPROC-1) proc_p2 = NPROC-1 ! set interval to maximum if user input is not correct - if(proc_p1 <= 0) proc_p1 = 0 - if(proc_p2 < 0) proc_p2 = NPROC - 1 + if (proc_p1 <= 0) proc_p1 = 0 + if (proc_p2 < 0) proc_p2 = NPROC - 1 ! set total number of points and elements to zero ntotpoin = 0 @@ -246,8 +246,8 @@ program combine_AVS_DX do iproc=0,NPROC-1 call random_number(random_val) ival_color = nint(random_val*NPROC) - if(ival_color < 0) ival_color = 0 - if(ival_color > NPROC-1) ival_color = NPROC-1 + if (ival_color < 0) ival_color = 0 + if (ival_color > NPROC-1) ival_color = NPROC-1 random_colors(iproc) = ival_color enddo @@ -259,9 +259,9 @@ program combine_AVS_DX ! create the name for the database of the current slide call create_serial_name_database(prname,iproc,LOCAL_PATH,NPROC,OUTPUT_FILES) - if(ivalue == 1) then + if (ivalue == 1) then open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointsfaces.txt',status='old',action='read') - else if(ivalue == 2) then + else if (ivalue == 2) then open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointssurface.txt',status='old',action='read') endif @@ -270,9 +270,9 @@ program combine_AVS_DX ntotpoin = ntotpoin + npoin close(10) - if(ivalue == 1) then + if (ivalue == 1) then open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementsfaces.txt',status='old',action='read') - else if(ivalue == 2) then + else if (ivalue == 2) then open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementssurface.txt',status='old',action='read') endif @@ -292,7 +292,7 @@ program combine_AVS_DX ntotspecAVS_DX = ntotspec ! use different name for surface and for slices - if(USE_OPENDX) then + if (USE_OPENDX) then open(unit=11,file=trim(OUTPUT_FILES)//'/DX_fullmesh.dx',status='unknown') write(11,*) 'object 1 class array type float rank 1 shape 3 items ',ntotpoinAVS_DX,' data follows' else @@ -300,8 +300,8 @@ program combine_AVS_DX endif ! write AVS or DX header with element data or point data - if(.not. USE_OPENDX) then - if(ivalue == 2 .and. icolor == 3) then + if (.not. USE_OPENDX) then + if (ivalue == 2 .and. icolor == 3) then write(11,*) ntotpoinAVS_DX,' ',ntotspecAVS_DX,' 1 0 0' else write(11,*) ntotpoinAVS_DX,' ',ntotspecAVS_DX,' 0 1 0' @@ -321,9 +321,9 @@ program combine_AVS_DX ! create the name for the database of the current slide call create_serial_name_database(prname,iproc,LOCAL_PATH,NPROC,OUTPUT_FILES) - if(ivalue == 1) then + if (ivalue == 1) then open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointsfaces.txt',status='old',action='read') - else if(ivalue == 2) then + else if (ivalue == 2) then open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointssurface.txt',status='old',action='read') endif @@ -333,14 +333,14 @@ program combine_AVS_DX ! read local points in this slice and output global AVS or DX points do ipoin=1,npoin read(10,*) numpoin,xval,yval,zval - if(numpoin /= ipoin) stop 'incorrect point number' + if (numpoin /= ipoin) stop 'incorrect point number' ! write to AVS or DX global file with correct offset - if(USE_OPENDX) then + if (USE_OPENDX) then write(11,*) sngl(xval),' ',sngl(yval),' ',sngl(zval*zscaling) else !! write(11,*) numpoin + iglobpointoffset,' ',sngl(xval),' ',sngl(yval),' ',sngl(zval*zscaling) !! XXX - if(zval < 0.) then + if (zval < 0.) then write(11,*) numpoin + iglobpointoffset,' ',sngl(xval),' ',sngl(yval),' ',sngl(zval*zscaling) else write(11,*) numpoin + iglobpointoffset,' ',sngl(xval),' ',sngl(yval),' ',' 0' @@ -366,7 +366,7 @@ program combine_AVS_DX iglobelemoffset = 0 maxdoubling = -1 - if(USE_OPENDX) & + if (USE_OPENDX) & write(11,*) 'object 2 class array type int rank 1 shape 4 items ',ntotspecAVS_DX,' data follows' ! loop on the selected range of processors @@ -377,10 +377,10 @@ program combine_AVS_DX ! create the name for the database of the current slide call create_serial_name_database(prname,iproc,LOCAL_PATH,NPROC,OUTPUT_FILES) - if(ivalue == 1) then + if (ivalue == 1) then open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementsfaces.txt',status='old',action='read') open(unit=12,file=prname(1:len_trim(prname))//'AVS_DXpointsfaces.txt',status='old',action='read') - else if(ivalue == 2) then + else if (ivalue == 2) then open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementssurface.txt',status='old',action='read') open(unit=12,file=prname(1:len_trim(prname))//'AVS_DXpointssurface.txt',status='old',action='read') endif @@ -394,14 +394,14 @@ program combine_AVS_DX ! read local elements in this slice and output global AVS or DX elements do ispec=1,nspec read(10,*) numelem,idoubling,iglob1,iglob2,iglob3,iglob4 - if(numelem /= ispec) stop 'incorrect element number' + if (numelem /= ispec) stop 'incorrect element number' ! compute max of the doubling flag maxdoubling = max(maxdoubling,idoubling) ! assign material property (which can be filtered later in AVS_DX) - if(imaterial == 1) then + if (imaterial == 1) then imatprop = idoubling - else if(imaterial == 2) then + else if (imaterial == 2) then imatprop = iproc else stop 'invalid code for material property' @@ -418,7 +418,7 @@ program combine_AVS_DX ! in the case of OpenDX, node numbers start at zero ! in the case of AVS, node numbers start at one ! point order in OpenDX is 1,4,2,3 *not* 1,2,3,4 as in AVS - if(USE_OPENDX) then + if (USE_OPENDX) then write(11,"(i6,1x,i6,1x,i6,1x,i6)") iglob1-1,iglob4-1,iglob2-1,iglob3-1 else write(11,"(i6,1x,i3,' quad ',i6,1x,i6,1x,i6,1x,i6)") numelem + iglobelemoffset,imatprop,iglob1,iglob2,iglob3,iglob4 @@ -437,10 +437,10 @@ program combine_AVS_DX ! ************* generate data values ****************** ! output AVS or DX header for data - if(USE_OPENDX) then + if (USE_OPENDX) then write(11,*) 'attribute "element type" string "quads"' write(11,*) 'attribute "ref" string "positions"' - if(ivalue == 2 .and. icolor == 3) then + if (ivalue == 2 .and. icolor == 3) then write(11,*) 'object 3 class array type float rank 0 items ',ntotpoinAVS_DX,' data follows' else write(11,*) 'object 3 class array type float rank 0 items ',ntotspecAVS_DX,' data follows' @@ -453,7 +453,7 @@ program combine_AVS_DX !!!! !!!! ###### element data in most cases !!!! - if(ivalue /= 2 .or. icolor /= 3) then + if (ivalue /= 2 .or. icolor /= 3) then ! set global element and point offsets to zero iglobelemoffset = 0 @@ -466,9 +466,9 @@ program combine_AVS_DX ! create the name for the database of the current slide call create_serial_name_database(prname,iproc,LOCAL_PATH,NPROC,OUTPUT_FILES) - if(ivalue == 1) then + if (ivalue == 1) then open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementsfaces.txt',status='old',action='read') - else if(ivalue == 2) then + else if (ivalue == 2) then open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementssurface.txt',status='old',action='read') endif @@ -478,21 +478,21 @@ program combine_AVS_DX ! read local elements in this slice and output global AVS or DX elements do ispec=1,nspec read(10,*) numelem,idoubling,iglob1,iglob2,iglob3,iglob4 - if(numelem /= ispec) stop 'incorrect element number' + if (numelem /= ispec) stop 'incorrect element number' ! data is either the slice number or the mesh doubling region flag - if(icolor == 1) then + if (icolor == 1) then val_color = dble(idoubling) - else if(icolor == 2) then + else if (icolor == 2) then val_color = dble(iproc) - else if(icolor == 4) then + else if (icolor == 4) then val_color = dble(random_colors(iproc)) else stop 'incorrect coloring code' endif ! write to AVS or DX global file with correct offset - if(USE_OPENDX) then + if (USE_OPENDX) then write(11,*) sngl(val_color) else write(11,*) numelem + iglobelemoffset,' ',sngl(val_color) @@ -529,9 +529,9 @@ program combine_AVS_DX ! read local points in this slice and output global AVS or DX points do ipoin=1,npoin read(10,*) numpoin,xval,yval,zval - if(numpoin /= ipoin) stop 'incorrect point number' + if (numpoin /= ipoin) stop 'incorrect point number' ! write to AVS or DX global file with correct offset - if(USE_OPENDX) then + if (USE_OPENDX) then write(11,*) sngl(zval) else write(11,*) numpoin + iglobpointoffset,' ',sngl(zval) @@ -548,8 +548,8 @@ program combine_AVS_DX endif ! end test if element data or point data ! define OpenDX field - if(USE_OPENDX) then - if(ivalue == 2 .and. icolor == 3) then + if (USE_OPENDX) then + if (ivalue == 2 .and. icolor == 3) then write(11,*) 'attribute "dep" string "positions"' else write(11,*) 'attribute "dep" string "connections"' @@ -571,7 +571,7 @@ program combine_AVS_DX ! create an AVS or DX file with the source and the receivers as well ! - if(USE_OPENDX) then + if (USE_OPENDX) then print * print *,'support for source and station file in OpenDX not added yet' @@ -621,13 +621,13 @@ program combine_AVS_DX nrec = 0 do while(ios == 0) read(11,"(a)",iostat=ios) dummystring - if(ios == 0) nrec = nrec + 1 + if (ios == 0) nrec = nrec + 1 enddo close(11) print *,'There are ',nrec,' three-component stations' print * - if(nrec < 1) stop 'incorrect number of stations read - need at least one' + if (nrec < 1) stop 'incorrect number of stations read - need at least one' allocate(station_name(nrec)) allocate(network_name(nrec)) diff --git a/utils/unused_routines/opendx_AVS/create_highres_shakemaps_AVS_DX.f90 b/utils/unused_routines/opendx_AVS/create_highres_shakemaps_AVS_DX.f90 index e850deebf..e3695ec9f 100644 --- a/utils/unused_routines/opendx_AVS/create_highres_shakemaps_AVS_DX.f90 +++ b/utils/unused_routines/opendx_AVS/create_highres_shakemaps_AVS_DX.f90 @@ -124,7 +124,7 @@ program create_movie_AVS_DX print *,'Recombining all movie frames to create a movie' print * - if(.not. SAVE_AVS_DX_MOVIE) stop 'movie frames were not saved by the solver' + if (.not. SAVE_AVS_DX_MOVIE) stop 'movie frames were not saved by the solver' print * print *,'reading parameter file' @@ -154,7 +154,7 @@ program create_movie_AVS_DX print *,'There are ',NPROC,' slices numbered from 0 to ',NPROC-1 print * - if(SAVE_DISPLACEMENT) then + if (SAVE_DISPLACEMENT) then print *,'Vertical displacement will be shown in movie' else print *,'Vertical velocity will be shown in movie' @@ -179,18 +179,18 @@ program create_movie_AVS_DX !!! read(5,*) iformat !! DK DK always GMT for shaking map iformat = 4 - if(iformat<1 .or. iformat>4) stop 'exiting...' - if(iformat == 1) then + if (iformat<1 .or. iformat>4) stop 'exiting...' + if (iformat == 1) then USE_OPENDX = .true. USE_AVS = .false. USE_GMT = .false. UNIQUE_FILE = .false. - else if(iformat == 2) then + else if (iformat == 2) then USE_OPENDX = .false. USE_AVS = .true. USE_GMT = .false. UNIQUE_FILE = .false. - else if(iformat == 3) then + else if (iformat == 3) then USE_OPENDX = .false. USE_AVS = .true. USE_GMT = .false. @@ -202,7 +202,7 @@ program create_movie_AVS_DX UNIQUE_FILE = .false. endif - if(.not. USE_GMT) then + if (.not. USE_GMT) then print * print *,'scaling to apply to Z to amplify topography (1. to do nothing, 0. to get flat surface):' read(5,*) zscaling @@ -217,9 +217,9 @@ program create_movie_AVS_DX print *,'enter first time step of movie (e.g. 1, enter -1 for shaking map)' !!! DK DK always shaking map read(5,*) it1 it1 = -1 - if(it1 == -1) plot_shaking_map = .true. + if (it1 == -1) plot_shaking_map = .true. - if(.not. plot_shaking_map) then + if (.not. plot_shaking_map) then print *,'enter last time step of movie (e.g. ',NSTEP,')' read(5,*) it2 @@ -231,7 +231,7 @@ program create_movie_AVS_DX print * print *,'enter value:' read(5,*) inumber - if(inumber<1 .or. inumber>2) stop 'exiting...' + if (inumber<1 .or. inumber>2) stop 'exiting...' print * print *,'looping from ',it1,' to ',it2,' every ',NMOVIE,' time steps' @@ -239,11 +239,11 @@ program create_movie_AVS_DX ! count number of movie frames nframes = 0 do it = it1,it2 - if(mod(it,NMOVIE) == 0) nframes = nframes + 1 + if (mod(it,NMOVIE) == 0) nframes = nframes + 1 enddo print * print *,'total number of frames will be ',nframes - if(nframes == 0) stop 'null number of frames' + if (nframes == 0) stop 'null number of frames' else @@ -254,13 +254,13 @@ program create_movie_AVS_DX endif iscaling_shake = 0 - if(plot_shaking_map) then + if (plot_shaking_map) then print * print *,'norm to display in shaking map:' print *,'1=displacement 2=velocity 3=acceleration' print * read(5,*) inorm - if(inorm < 1 .or. inorm > 3) stop 'incorrect value of inorm' + if (inorm < 1 .or. inorm > 3) stop 'incorrect value of inorm' print * print *,'apply non-linear scaling to shaking map:' @@ -268,7 +268,7 @@ program create_movie_AVS_DX print * !! DK DK no scaling read(5,*) iscaling_shake iscaling_shake = 2 - if(iscaling_shake < 1 .or. iscaling_shake > 2) stop 'incorrect value of iscaling_shake' + if (iscaling_shake < 1 .or. iscaling_shake > 2) stop 'incorrect value of iscaling_shake' endif ! define the total number of elements at the surface @@ -291,8 +291,8 @@ program create_movie_AVS_DX allocate(ireorder(npointot)) print * - if(APPLY_THRESHOLD .and. .not. plot_shaking_map) print *,'Will apply a threshold to amplitude below ',100.*THRESHOLD,' %' - if(NONLINEAR_SCALING .and. (.not. plot_shaking_map .or. iscaling_shake == 1)) & + if (APPLY_THRESHOLD .and. .not. plot_shaking_map) print *,'Will apply a threshold to amplitude below ',100.*THRESHOLD,' %' + if (NONLINEAR_SCALING .and. (.not. plot_shaking_map .or. iscaling_shake == 1)) & print *,'Will apply a non linear scaling with coef ',POWER_SCALING ! define indirect addressing for GMT @@ -317,12 +317,12 @@ program create_movie_AVS_DX do it = it1,it2 ! check if time step corresponds to a movie frame - if(mod(it,NMOVIE) == 0 .or. plot_shaking_map) then + if (mod(it,NMOVIE) == 0 .or. plot_shaking_map) then iframe = iframe + 1 print * - if(plot_shaking_map) then + if (plot_shaking_map) then print *,'reading shaking map snapshot' else print *,'reading snapshot time step ',it,' out of ',NSTEP @@ -330,7 +330,7 @@ program create_movie_AVS_DX print * ! read all the elements from the same file - if(plot_shaking_map) then + if (plot_shaking_map) then write(outputname,"('OUTPUT_FILES/shakingdata')") else write(outputname,"('OUTPUT_FILES/moviedata',i6.6)") it @@ -381,10 +381,10 @@ program create_movie_AVS_DX ! show vertical component of displacement or velocity in the movie ! or show norm of vector if shaking map ! for shaking map, norm of U stored in ux, V in uy and A in uz - if(plot_shaking_map) then - if(inorm == 1) then + if (plot_shaking_map) then + if (inorm == 1) then field_display(ilocnum+ieoff) = dble(vectorx) - else if(inorm == 2) then + else if (inorm == 2) then field_display(ilocnum+ieoff) = dble(vectory) else field_display(ilocnum+ieoff) = dble(vectorz) @@ -426,7 +426,7 @@ program create_movie_AVS_DX print * ! apply scaling in all cases for movies - if(.not. plot_shaking_map) then + if (.not. plot_shaking_map) then ! make sure range is always symmetric and center is in zero ! this assumption works only for fields that can be negative @@ -443,11 +443,11 @@ program create_movie_AVS_DX field_display(:) = 2.*field_display(:) - 1. ! apply threshold to normalized field - if(APPLY_THRESHOLD) & + if (APPLY_THRESHOLD) & where(abs(field_display(:)) <= THRESHOLD) field_display = 0. ! apply non linear scaling to normalized field if needed - if(NONLINEAR_SCALING) then + if (NONLINEAR_SCALING) then where(field_display(:) >= 0.) field_display = field_display ** POWER_SCALING elsewhere @@ -456,7 +456,7 @@ program create_movie_AVS_DX endif ! apply non linear scaling to normalized field if needed - if(NONLINEAR_SCALING) then + if (NONLINEAR_SCALING) then where(field_display(:) >= 0.) field_display = field_display ** POWER_SCALING elsewhere @@ -473,7 +473,7 @@ program create_movie_AVS_DX ! apply scaling only if selected for shaking map - else if(NONLINEAR_SCALING .and. iscaling_shake == 1) then + else if (NONLINEAR_SCALING .and. iscaling_shake == 1) then ! normalize field to [0:1] field_display(:) = field_display(:) / max_field_current @@ -488,25 +488,25 @@ program create_movie_AVS_DX !--- ****** create AVS file using sorted list ****** - if(inumber == 1) then + if (inumber == 1) then ivalue = iframe else ivalue = it endif ! create file name and open file - if(plot_shaking_map) then + if (plot_shaking_map) then - if(USE_OPENDX) then + if (USE_OPENDX) then write(outputname,"('OUTPUT_FILES/DX_shaking_map.dx')") open(unit=11,file=outputname,status='unknown') write(11,*) 'object 1 class array type float rank 1 shape 3 items ',nglob,' data follows' - else if(USE_AVS) then - if(UNIQUE_FILE) stop 'cannot use unique file AVS option for shaking map' + else if (USE_AVS) then + if (UNIQUE_FILE) stop 'cannot use unique file AVS option for shaking map' write(outputname,"('OUTPUT_FILES/AVS_shaking_map.inp')") open(unit=11,file=outputname,status='unknown') write(11,*) nglob,' ',nspectot_AVS_max,' 1 0 0' - else if(USE_GMT) then + else if (USE_GMT) then write(outputname,"('OUTPUT_FILES/gmt_shaking_map.xyz')") open(unit=11,file=outputname,status='unknown') else @@ -515,23 +515,23 @@ program create_movie_AVS_DX else - if(USE_OPENDX) then + if (USE_OPENDX) then write(outputname,"('OUTPUT_FILES/DX_movie_',i6.6,'.dx')") ivalue open(unit=11,file=outputname,status='unknown') write(11,*) 'object 1 class array type float rank 1 shape 3 items ',nglob,' data follows' - else if(USE_AVS) then - if(UNIQUE_FILE .and. iframe == 1) then + else if (USE_AVS) then + if (UNIQUE_FILE .and. iframe == 1) then open(unit=11,file='OUTPUT_FILES/AVS_movie_all.inp',status='unknown') write(11,*) nframes write(11,*) 'data' write(11,401) 1,1 write(11,*) nglob,' ',nspectot_AVS_max - else if(.not. UNIQUE_FILE) then + else if (.not. UNIQUE_FILE) then write(outputname,"('OUTPUT_FILES/AVS_movie_',i6.6,'.inp')") ivalue open(unit=11,file=outputname,status='unknown') write(11,*) nglob,' ',nspectot_AVS_max,' 1 0 0' endif - else if(USE_GMT) then + else if (USE_GMT) then write(outputname,"('OUTPUT_FILES/gmt_movie_',i6.6,'.xyz')") ivalue open(unit=11,file=outputname,status='unknown') else @@ -553,14 +553,14 @@ program create_movie_AVS_DX ! four points for each element do ilocnum = 1,NGNOD2D_AVS_DX_HIGHRES ibool_number = iglob(ilocnum+ieoff) - if(.not. mask_point(ibool_number)) then + if (.not. mask_point(ibool_number)) then ipoin = ipoin + 1 !! DK DK for GMT map, we ignore Z (flat view from the top) utm_x_current = xp_save(ilocnum+ieoff) utm_y_current = yp_save(ilocnum+ieoff) call utm_geo(long_current,lat_current,utm_x_current,utm_y_current,UTM_PROJECTION_ZONE,IUTM2LONGLAT) !! DK DK extract closeup region for L.A. basin - if(long_current >= -119.8 .and. long_current <= -117.2 .and. lat_current >= 32.7 .and. lat_current <= 35.3) & + if (long_current >= -119.8 .and. long_current <= -117.2 .and. lat_current >= 32.7 .and. lat_current <= 35.3) & write(11,*) long_current,lat_current,field_display(ilocnum+ieoff) endif mask_point(ibool_number) = .true. @@ -574,7 +574,7 @@ program create_movie_AVS_DX ! if GMT format is used, use regular grid in longitude and latitude ! and ignore elevation (flat 2D movie seen from the top) - if(USE_GMT) then + if (USE_GMT) then size_slice_xi = (UTM_X_MAX-UTM_X_MIN) / dble(NPROC_XI) size_slice_eta = (UTM_Y_MAX-UTM_Y_MIN) / dble(NPROC_ETA) @@ -596,32 +596,32 @@ program create_movie_AVS_DX ratio_slice_xi = ratio_xi - int(ratio_xi) ratio_slice_eta = ratio_eta - int(ratio_eta) - if(ratio_slice_xi < 0.) ratio_slice_xi = 0. - if(ratio_slice_xi > 0.999) ratio_slice_xi = 0.999 + if (ratio_slice_xi < 0.) ratio_slice_xi = 0. + if (ratio_slice_xi > 0.999) ratio_slice_xi = 0.999 - if(ratio_slice_eta < 0.) ratio_slice_eta = 0. - if(ratio_slice_eta > 0.999) ratio_slice_eta = 0.999 + if (ratio_slice_eta < 0.) ratio_slice_eta = 0. + if (ratio_slice_eta > 0.999) ratio_slice_eta = 0.999 ratio_slice_xi = ratio_slice_xi * NEX_PER_PROC_XI ratio_slice_eta = ratio_slice_eta * NEX_PER_PROC_ETA ! define slice number islice_x = int(ratio_xi) + 1 - if(islice_x < 1) islice_x = 1 - if(islice_x > NPROC_XI) islice_x = NPROC_XI + if (islice_x < 1) islice_x = 1 + if (islice_x > NPROC_XI) islice_x = NPROC_XI islice_y = int(ratio_eta) + 1 - if(islice_y < 1) islice_y = 1 - if(islice_y > NPROC_ETA) islice_y = NPROC_ETA + if (islice_y < 1) islice_y = 1 + if (islice_y > NPROC_ETA) islice_y = NPROC_ETA ! define element number ispec_x = int(ratio_slice_xi) + 1 - if(ispec_x < 1) ispec_x = 1 - if(ispec_x > NEX_PER_PROC_XI) ispec_x = NEX_PER_PROC_XI + if (ispec_x < 1) ispec_x = 1 + if (ispec_x > NEX_PER_PROC_XI) ispec_x = NEX_PER_PROC_XI ispec_y = int(ratio_slice_eta) + 1 - if(ispec_y < 1) ispec_y = 1 - if(ispec_y > NEX_PER_PROC_ETA) ispec_y = NEX_PER_PROC_ETA + if (ispec_y < 1) ispec_y = 1 + if (ispec_y > NEX_PER_PROC_ETA) ispec_y = NEX_PER_PROC_ETA ! get corresponding spectral element ispec = ispecGMT_store(ispec_x,ispec_y,islice_x,islice_y) @@ -639,10 +639,10 @@ program create_movie_AVS_DX ratio_eta = (utm_y_current - yval(1)) / (yval(4) - yval(1)) ! avoid edge effects - if(ratio_xi < 0.) ratio_xi = 0. - if(ratio_xi > 1.) ratio_xi = 1. - if(ratio_eta < 0.) ratio_eta = 0. - if(ratio_eta > 1.) ratio_eta = 1. + if (ratio_xi < 0.) ratio_xi = 0. + if (ratio_xi > 1.) ratio_xi = 1. + if (ratio_eta < 0.) ratio_eta = 0. + if (ratio_eta > 1.) ratio_eta = 1. ! interpolate data value dataval_interp = dataval(1)*(1.-ratio_xi)*(1.-ratio_eta) + & @@ -659,7 +659,7 @@ program create_movie_AVS_DX else ! if unique file, output geometry only once - if(.not. UNIQUE_FILE .or. iframe == 1) then + if (.not. UNIQUE_FILE .or. iframe == 1) then ! output list of points mask_point = .false. @@ -669,15 +669,15 @@ program create_movie_AVS_DX ! four points for each element do ilocnum = 1,NGNOD2D_AVS_DX_HIGHRES ibool_number = iglob(ilocnum+ieoff) - if(.not. mask_point(ibool_number)) then + if (.not. mask_point(ibool_number)) then ipoin = ipoin + 1 ireorder(ibool_number) = ipoin - if(USE_OPENDX) then + if (USE_OPENDX) then write(11,*) sngl(xp_save(ilocnum+ieoff)),sngl(yp_save(ilocnum+ieoff)),sngl(zp_save(ilocnum+ieoff)) - else if(USE_AVS) then + else if (USE_AVS) then write(11,*) ireorder(ibool_number),sngl(xp_save(ilocnum+ieoff)), & sngl(yp_save(ilocnum+ieoff)),sngl(zp_save(ilocnum+ieoff)) - else if(USE_GMT) then + else if (USE_GMT) then write(11,*) sngl(xp_save(ilocnum+ieoff)),sngl(yp_save(ilocnum+ieoff)),sngl(zp_save(ilocnum+ieoff)) endif endif @@ -685,7 +685,7 @@ program create_movie_AVS_DX enddo enddo - if(USE_OPENDX) & + if (USE_OPENDX) & write(11,*) 'object 2 class array type int rank 1 shape 4 items ',nspectot_AVS_max,' data follows' ! output list of elements @@ -696,7 +696,7 @@ program create_movie_AVS_DX ibool_number2 = iglob(ieoff + 2) ibool_number3 = iglob(ieoff + 3) ibool_number4 = iglob(ieoff + 4) - if(USE_OPENDX) then + if (USE_OPENDX) then ! point order in OpenDX is 1,4,2,3 *not* 1,2,3,4 as in AVS write(11,210) ireorder(ibool_number1)-1,ireorder(ibool_number4)-1,ireorder(ibool_number2)-1,ireorder(ibool_number3)-1 else @@ -709,18 +709,18 @@ program create_movie_AVS_DX endif - if(USE_OPENDX) then + if (USE_OPENDX) then write(11,*) 'attribute "element type" string "quads"' write(11,*) 'attribute "ref" string "positions"' write(11,*) 'object 3 class array type float rank 0 items ',nglob,' data follows' else - if(UNIQUE_FILE) then - if(iframe > 1) then - if(iframe < 10) then + if (UNIQUE_FILE) then + if (iframe > 1) then + if (iframe < 10) then write(11,401) iframe,iframe - else if(iframe < 100) then + else if (iframe < 100) then write(11,402) iframe,iframe - else if(iframe < 1000) then + else if (iframe < 1000) then write(11,403) iframe,iframe else write(11,404) iframe,iframe @@ -748,15 +748,15 @@ program create_movie_AVS_DX ! four points for each element do ilocnum = 1,NGNOD2D_AVS_DX_HIGHRES ibool_number = iglob(ilocnum+ieoff) - if(.not. mask_point(ibool_number)) then - if(USE_OPENDX) then - if(plot_shaking_map) then + if (.not. mask_point(ibool_number)) then + if (USE_OPENDX) then + if (plot_shaking_map) then write(11,*) field_display(ilocnum+ieoff) else write(11,501) field_display(ilocnum+ieoff) endif else - if(plot_shaking_map) then + if (plot_shaking_map) then write(11,*) ireorder(ibool_number),field_display(ilocnum+ieoff) else write(11,502) ireorder(ibool_number),field_display(ilocnum+ieoff) @@ -771,7 +771,7 @@ program create_movie_AVS_DX 502 format(i6,1x,f7.2) ! define OpenDX field - if(USE_OPENDX) then + if (USE_OPENDX) then write(11,*) 'attribute "dep" string "positions"' write(11,*) 'object "irregular positions irregular connections" class field' write(11,*) 'component "positions" value 1' @@ -783,20 +783,20 @@ program create_movie_AVS_DX ! end of test for GMT format endif - if(.not. UNIQUE_FILE) close(11) + if (.not. UNIQUE_FILE) close(11) ! end of loop and test on all the time steps for all the movie images endif enddo - if(UNIQUE_FILE) close(11) + if (UNIQUE_FILE) close(11) print * print *,'done creating movie or shaking map' print * - if(USE_OPENDX) print *,'DX files are stored in OUTPUT_FILES/DX_*.dx' - if(USE_AVS) print *,'AVS files are stored in OUTPUT_FILES/AVS_*.inp' - if(USE_GMT) then + if (USE_OPENDX) print *,'DX files are stored in OUTPUT_FILES/DX_*.dx' + if (USE_AVS) print *,'AVS files are stored in OUTPUT_FILES/AVS_*.inp' + if (USE_GMT) then print *,'GMT files are stored in OUTPUT_FILES/gmt_*.xyz' print * print *,'number of points in longitude in GMT grid = ',NEX_XI+1 @@ -870,9 +870,9 @@ subroutine get_global_AVS(nspec,xp,yp,zp,iglob,loc,ifseg,nglob,npointot,UTM_X_MI ! sort within each segment ioff=1 do iseg=1,nseg - if(j == 1) then + if (j == 1) then call rank(xp(ioff),ind,ninseg(iseg)) - else if(j == 2) then + else if (j == 2) then call rank(yp(ioff),ind,ninseg(iseg)) else call rank(zp(ioff),ind,ninseg(iseg)) @@ -883,24 +883,24 @@ subroutine get_global_AVS(nspec,xp,yp,zp,iglob,loc,ifseg,nglob,npointot,UTM_X_MI ! check for jumps in current coordinate ! compare the coordinates of the points within a small tolerance - if(j == 1) then + if (j == 1) then do i=2,npointot - if(dabs(xp(i)-xp(i-1)) > SMALLVALTOL) ifseg(i)=.true. + if (dabs(xp(i)-xp(i-1)) > SMALLVALTOL) ifseg(i)=.true. enddo - else if(j == 2) then + else if (j == 2) then do i=2,npointot - if(dabs(yp(i)-yp(i-1)) > SMALLVALTOL) ifseg(i)=.true. + if (dabs(yp(i)-yp(i-1)) > SMALLVALTOL) ifseg(i)=.true. enddo else do i=2,npointot - if(dabs(zp(i)-zp(i-1)) > SMALLVALTOL) ifseg(i)=.true. + if (dabs(zp(i)-zp(i-1)) > SMALLVALTOL) ifseg(i)=.true. enddo endif ! count up number of different segments nseg=0 do i=1,npointot - if(ifseg(i)) then + if (ifseg(i)) then nseg=nseg+1 ninseg(nseg)=1 else @@ -912,7 +912,7 @@ subroutine get_global_AVS(nspec,xp,yp,zp,iglob,loc,ifseg,nglob,npointot,UTM_X_MI ! assign global node numbers (now sorted lexicographically) ig=0 do i=1,npointot - if(ifseg(i)) ig=ig+1 + if (ifseg(i)) ig=ig+1 iglob(loc(i))=ig enddo @@ -951,8 +951,8 @@ subroutine rank(A,IND,N) L=n/2+1 ir=n - 100 CONTINUE - IF (l>1) THEN + 100 continue + if (l>1) then l=l-1 indx=ind(l) q=a(indx) @@ -968,12 +968,12 @@ subroutine rank(A,IND,N) endif i=l j=l+l - 200 CONTINUE - IF (J <= IR) THEN - IF (J4) stop 'exiting...' - if(iformat == 1) then + if (iformat<1 .or. iformat>4) stop 'exiting...' + if (iformat == 1) then USE_OPENDX = .true. USE_AVS = .false. USE_GMT = .false. UNIQUE_FILE = .false. - else if(iformat == 2) then + else if (iformat == 2) then USE_OPENDX = .false. USE_AVS = .true. USE_GMT = .false. UNIQUE_FILE = .false. - else if(iformat == 3) then + else if (iformat == 3) then USE_OPENDX = .false. USE_AVS = .true. USE_GMT = .false. @@ -203,7 +203,7 @@ program create_movie_AVS_DX UNIQUE_FILE = .false. endif - if(.not. USE_GMT) then + if (.not. USE_GMT) then print * print *,'scaling to apply to Z to amplify topography (1. to do nothing, 0. to get flat surface):' read(5,*) zscaling @@ -218,9 +218,9 @@ program create_movie_AVS_DX print *,'enter first time step of movie (e.g. 1, enter -1 for shaking map)' !!! DK DK always shaking map read(5,*) it1 it1 = -1 - if(it1 == -1) plot_shaking_map = .true. + if (it1 == -1) plot_shaking_map = .true. - if(.not. plot_shaking_map) then + if (.not. plot_shaking_map) then print *,'enter last time step of movie (e.g. ',NSTEP,')' read(5,*) it2 @@ -232,7 +232,7 @@ program create_movie_AVS_DX print * print *,'enter value:' read(5,*) inumber - if(inumber<1 .or. inumber>2) stop 'exiting...' + if (inumber<1 .or. inumber>2) stop 'exiting...' print * print *,'looping from ',it1,' to ',it2,' every ',NMOVIE,' time steps' @@ -240,11 +240,11 @@ program create_movie_AVS_DX ! count number of movie frames nframes = 0 do it = it1,it2 - if(mod(it,NMOVIE) == 0) nframes = nframes + 1 + if (mod(it,NMOVIE) == 0) nframes = nframes + 1 enddo print * print *,'total number of frames will be ',nframes - if(nframes == 0) stop 'null number of frames' + if (nframes == 0) stop 'null number of frames' else @@ -255,13 +255,13 @@ program create_movie_AVS_DX endif iscaling_shake = 0 - if(plot_shaking_map) then + if (plot_shaking_map) then print * print *,'norm to display in shaking map:' print *,'1=displacement 2=velocity 3=acceleration' print * read(5,*) inorm - if(inorm < 1 .or. inorm > 3) stop 'incorrect value of inorm' + if (inorm < 1 .or. inorm > 3) stop 'incorrect value of inorm' print * print *,'apply non-linear scaling to shaking map:' @@ -269,7 +269,7 @@ program create_movie_AVS_DX print * !! DK DK no scaling read(5,*) iscaling_shake iscaling_shake = 2 - if(iscaling_shake < 1 .or. iscaling_shake > 2) stop 'incorrect value of iscaling_shake' + if (iscaling_shake < 1 .or. iscaling_shake > 2) stop 'incorrect value of iscaling_shake' endif ! define the total number of elements at the surface @@ -292,8 +292,8 @@ program create_movie_AVS_DX allocate(ireorder(npointot)) print * - if(APPLY_THRESHOLD .and. .not. plot_shaking_map) print *,'Will apply a threshold to amplitude below ',100.*THRESHOLD,' %' - if(NONLINEAR_SCALING .and. (.not. plot_shaking_map .or. iscaling_shake == 1)) & + if (APPLY_THRESHOLD .and. .not. plot_shaking_map) print *,'Will apply a threshold to amplitude below ',100.*THRESHOLD,' %' + if (NONLINEAR_SCALING .and. (.not. plot_shaking_map .or. iscaling_shake == 1)) & print *,'Will apply a non linear scaling with coef ',POWER_SCALING ! define indirect addressing for GMT @@ -318,12 +318,12 @@ program create_movie_AVS_DX do it = it1,it2 ! check if time step corresponds to a movie frame - if(mod(it,NMOVIE) == 0 .or. plot_shaking_map) then + if (mod(it,NMOVIE) == 0 .or. plot_shaking_map) then iframe = iframe + 1 print * - if(plot_shaking_map) then + if (plot_shaking_map) then print *,'reading shaking map snapshot' else print *,'reading snapshot time step ',it,' out of ',NSTEP @@ -331,7 +331,7 @@ program create_movie_AVS_DX print * ! read all the elements from the same file - if(plot_shaking_map) then + if (plot_shaking_map) then write(outputname,"('OUTPUT_FILES/shakingdata')") else write(outputname,"('OUTPUT_FILES/moviedata',i6.6)") it @@ -382,10 +382,10 @@ program create_movie_AVS_DX ! show vertical component of displacement or velocity in the movie ! or show norm of vector if shaking map ! for shaking map, norm of U stored in ux, V in uy and A in uz - if(plot_shaking_map) then - if(inorm == 1) then + if (plot_shaking_map) then + if (inorm == 1) then field_display(ilocnum+ieoff) = dble(vectorx) - else if(inorm == 2) then + else if (inorm == 2) then field_display(ilocnum+ieoff) = dble(vectory) else field_display(ilocnum+ieoff) = dble(vectorz) @@ -427,7 +427,7 @@ program create_movie_AVS_DX print * ! apply scaling in all cases for movies - if(.not. plot_shaking_map) then + if (.not. plot_shaking_map) then ! make sure range is always symmetric and center is in zero ! this assumption works only for fields that can be negative @@ -444,11 +444,11 @@ program create_movie_AVS_DX field_display(:) = 2.*field_display(:) - 1. ! apply threshold to normalized field - if(APPLY_THRESHOLD) & + if (APPLY_THRESHOLD) & where(abs(field_display(:)) <= THRESHOLD) field_display = 0. ! apply non linear scaling to normalized field if needed - if(NONLINEAR_SCALING) then + if (NONLINEAR_SCALING) then where(field_display(:) >= 0.) field_display = field_display ** POWER_SCALING elsewhere @@ -457,7 +457,7 @@ program create_movie_AVS_DX endif ! apply non linear scaling to normalized field if needed - if(NONLINEAR_SCALING) then + if (NONLINEAR_SCALING) then where(field_display(:) >= 0.) field_display = field_display ** POWER_SCALING elsewhere @@ -474,7 +474,7 @@ program create_movie_AVS_DX ! apply scaling only if selected for shaking map - else if(NONLINEAR_SCALING .and. iscaling_shake == 1) then + else if (NONLINEAR_SCALING .and. iscaling_shake == 1) then ! normalize field to [0:1] field_display(:) = field_display(:) / max_field_current @@ -489,25 +489,25 @@ program create_movie_AVS_DX !--- ****** create AVS file using sorted list ****** - if(inumber == 1) then + if (inumber == 1) then ivalue = iframe else ivalue = it endif ! create file name and open file - if(plot_shaking_map) then + if (plot_shaking_map) then - if(USE_OPENDX) then + if (USE_OPENDX) then write(outputname,"('OUTPUT_FILES/DX_shaking_map.dx')") open(unit=11,file=outputname,status='unknown') write(11,*) 'object 1 class array type float rank 1 shape 3 items ',nglob,' data follows' - else if(USE_AVS) then - if(UNIQUE_FILE) stop 'cannot use unique file AVS option for shaking map' + else if (USE_AVS) then + if (UNIQUE_FILE) stop 'cannot use unique file AVS option for shaking map' write(outputname,"('OUTPUT_FILES/AVS_shaking_map.inp')") open(unit=11,file=outputname,status='unknown') write(11,*) nglob,' ',nspectot_AVS_max,' 1 0 0' - else if(USE_GMT) then + else if (USE_GMT) then write(outputname,"('OUTPUT_FILES/gmt_shaking_map.xyz')") open(unit=11,file=outputname,status='unknown') else @@ -516,23 +516,23 @@ program create_movie_AVS_DX else - if(USE_OPENDX) then + if (USE_OPENDX) then write(outputname,"('OUTPUT_FILES/DX_movie_',i6.6,'.dx')") ivalue open(unit=11,file=outputname,status='unknown') write(11,*) 'object 1 class array type float rank 1 shape 3 items ',nglob,' data follows' - else if(USE_AVS) then - if(UNIQUE_FILE .and. iframe == 1) then + else if (USE_AVS) then + if (UNIQUE_FILE .and. iframe == 1) then open(unit=11,file='OUTPUT_FILES/AVS_movie_all.inp',status='unknown') write(11,*) nframes write(11,*) 'data' write(11,401) 1,1 write(11,*) nglob,' ',nspectot_AVS_max - else if(.not. UNIQUE_FILE) then + else if (.not. UNIQUE_FILE) then write(outputname,"('OUTPUT_FILES/AVS_movie_',i6.6,'.inp')") ivalue open(unit=11,file=outputname,status='unknown') write(11,*) nglob,' ',nspectot_AVS_max,' 1 0 0' endif - else if(USE_GMT) then + else if (USE_GMT) then write(outputname,"('OUTPUT_FILES/gmt_movie_',i6.6,'.xyz')") ivalue open(unit=11,file=outputname,status='unknown') else @@ -554,14 +554,14 @@ program create_movie_AVS_DX ! four points for each element do ilocnum = 1,NGNOD2D_AVS_DX_HIGHRES ibool_number = iglob(ilocnum+ieoff) - if(.not. mask_point(ibool_number)) then + if (.not. mask_point(ibool_number)) then ipoin = ipoin + 1 !! DK DK for GMT map, we ignore Z (flat view from the top) utm_x_current = xp_save(ilocnum+ieoff) utm_y_current = yp_save(ilocnum+ieoff) call utm_geo(long_current,lat_current,utm_x_current,utm_y_current,UTM_PROJECTION_ZONE,IUTM2LONGLAT) !! DK DK extract closeup region for L.A. basin - if(long_current >= -119.8 .and. long_current <= -117.2 .and. lat_current >= 32.7 .and. lat_current <= 35.3) & + if (long_current >= -119.8 .and. long_current <= -117.2 .and. lat_current >= 32.7 .and. lat_current <= 35.3) & write(11,*) long_current,lat_current,field_display(ilocnum+ieoff) endif mask_point(ibool_number) = .true. @@ -575,7 +575,7 @@ program create_movie_AVS_DX ! if GMT format is used, use regular grid in longitude and latitude ! and ignore elevation (flat 2D movie seen from the top) - if(USE_GMT) then + if (USE_GMT) then size_slice_xi = (UTM_X_MAX-UTM_X_MIN) / dble(NPROC_XI) size_slice_eta = (UTM_Y_MAX-UTM_Y_MIN) / dble(NPROC_ETA) @@ -597,32 +597,32 @@ program create_movie_AVS_DX ratio_slice_xi = ratio_xi - int(ratio_xi) ratio_slice_eta = ratio_eta - int(ratio_eta) - if(ratio_slice_xi < 0.) ratio_slice_xi = 0. - if(ratio_slice_xi > 0.999) ratio_slice_xi = 0.999 + if (ratio_slice_xi < 0.) ratio_slice_xi = 0. + if (ratio_slice_xi > 0.999) ratio_slice_xi = 0.999 - if(ratio_slice_eta < 0.) ratio_slice_eta = 0. - if(ratio_slice_eta > 0.999) ratio_slice_eta = 0.999 + if (ratio_slice_eta < 0.) ratio_slice_eta = 0. + if (ratio_slice_eta > 0.999) ratio_slice_eta = 0.999 ratio_slice_xi = ratio_slice_xi * NEX_PER_PROC_XI ratio_slice_eta = ratio_slice_eta * NEX_PER_PROC_ETA ! define slice number islice_x = int(ratio_xi) + 1 - if(islice_x < 1) islice_x = 1 - if(islice_x > NPROC_XI) islice_x = NPROC_XI + if (islice_x < 1) islice_x = 1 + if (islice_x > NPROC_XI) islice_x = NPROC_XI islice_y = int(ratio_eta) + 1 - if(islice_y < 1) islice_y = 1 - if(islice_y > NPROC_ETA) islice_y = NPROC_ETA + if (islice_y < 1) islice_y = 1 + if (islice_y > NPROC_ETA) islice_y = NPROC_ETA ! define element number ispec_x = int(ratio_slice_xi) + 1 - if(ispec_x < 1) ispec_x = 1 - if(ispec_x > NEX_PER_PROC_XI) ispec_x = NEX_PER_PROC_XI + if (ispec_x < 1) ispec_x = 1 + if (ispec_x > NEX_PER_PROC_XI) ispec_x = NEX_PER_PROC_XI ispec_y = int(ratio_slice_eta) + 1 - if(ispec_y < 1) ispec_y = 1 - if(ispec_y > NEX_PER_PROC_ETA) ispec_y = NEX_PER_PROC_ETA + if (ispec_y < 1) ispec_y = 1 + if (ispec_y > NEX_PER_PROC_ETA) ispec_y = NEX_PER_PROC_ETA ! get corresponding spectral element ispec = ispecGMT_store(ispec_x,ispec_y,islice_x,islice_y) @@ -640,10 +640,10 @@ program create_movie_AVS_DX ratio_eta = (utm_y_current - yval(1)) / (yval(4) - yval(1)) ! avoid edge effects - if(ratio_xi < 0.) ratio_xi = 0. - if(ratio_xi > 1.) ratio_xi = 1. - if(ratio_eta < 0.) ratio_eta = 0. - if(ratio_eta > 1.) ratio_eta = 1. + if (ratio_xi < 0.) ratio_xi = 0. + if (ratio_xi > 1.) ratio_xi = 1. + if (ratio_eta < 0.) ratio_eta = 0. + if (ratio_eta > 1.) ratio_eta = 1. ! interpolate data value dataval_interp = dataval(1)*(1.-ratio_xi)*(1.-ratio_eta) + & @@ -660,7 +660,7 @@ program create_movie_AVS_DX else ! if unique file, output geometry only once - if(.not. UNIQUE_FILE .or. iframe == 1) then + if (.not. UNIQUE_FILE .or. iframe == 1) then ! output list of points mask_point = .false. @@ -670,15 +670,15 @@ program create_movie_AVS_DX ! four points for each element do ilocnum = 1,NGNOD2D_AVS_DX_HIGHRES ibool_number = iglob(ilocnum+ieoff) - if(.not. mask_point(ibool_number)) then + if (.not. mask_point(ibool_number)) then ipoin = ipoin + 1 ireorder(ibool_number) = ipoin - if(USE_OPENDX) then + if (USE_OPENDX) then write(11,*) sngl(xp_save(ilocnum+ieoff)),sngl(yp_save(ilocnum+ieoff)),sngl(zp_save(ilocnum+ieoff)) - else if(USE_AVS) then + else if (USE_AVS) then write(11,*) ireorder(ibool_number),sngl(xp_save(ilocnum+ieoff)), & sngl(yp_save(ilocnum+ieoff)),sngl(zp_save(ilocnum+ieoff)) - else if(USE_GMT) then + else if (USE_GMT) then write(11,*) sngl(xp_save(ilocnum+ieoff)),sngl(yp_save(ilocnum+ieoff)),sngl(zp_save(ilocnum+ieoff)) endif endif @@ -686,7 +686,7 @@ program create_movie_AVS_DX enddo enddo - if(USE_OPENDX) & + if (USE_OPENDX) & write(11,*) 'object 2 class array type int rank 1 shape 4 items ',nspectot_AVS_max,' data follows' ! output list of elements @@ -697,7 +697,7 @@ program create_movie_AVS_DX ibool_number2 = iglob(ieoff + 2) ibool_number3 = iglob(ieoff + 3) ibool_number4 = iglob(ieoff + 4) - if(USE_OPENDX) then + if (USE_OPENDX) then ! point order in OpenDX is 1,4,2,3 *not* 1,2,3,4 as in AVS write(11,210) ireorder(ibool_number1)-1,ireorder(ibool_number4)-1,ireorder(ibool_number2)-1,ireorder(ibool_number3)-1 else @@ -710,18 +710,18 @@ program create_movie_AVS_DX endif - if(USE_OPENDX) then + if (USE_OPENDX) then write(11,*) 'attribute "element type" string "quads"' write(11,*) 'attribute "ref" string "positions"' write(11,*) 'object 3 class array type float rank 0 items ',nglob,' data follows' else - if(UNIQUE_FILE) then - if(iframe > 1) then - if(iframe < 10) then + if (UNIQUE_FILE) then + if (iframe > 1) then + if (iframe < 10) then write(11,401) iframe,iframe - else if(iframe < 100) then + else if (iframe < 100) then write(11,402) iframe,iframe - else if(iframe < 1000) then + else if (iframe < 1000) then write(11,403) iframe,iframe else write(11,404) iframe,iframe @@ -749,15 +749,15 @@ program create_movie_AVS_DX ! four points for each element do ilocnum = 1,NGNOD2D_AVS_DX_HIGHRES ibool_number = iglob(ilocnum+ieoff) - if(.not. mask_point(ibool_number)) then - if(USE_OPENDX) then - if(plot_shaking_map) then + if (.not. mask_point(ibool_number)) then + if (USE_OPENDX) then + if (plot_shaking_map) then write(11,*) field_display(ilocnum+ieoff) else write(11,501) field_display(ilocnum+ieoff) endif else - if(plot_shaking_map) then + if (plot_shaking_map) then write(11,*) ireorder(ibool_number),field_display(ilocnum+ieoff) else write(11,502) ireorder(ibool_number),field_display(ilocnum+ieoff) @@ -772,7 +772,7 @@ program create_movie_AVS_DX 502 format(i6,1x,f7.2) ! define OpenDX field - if(USE_OPENDX) then + if (USE_OPENDX) then write(11,*) 'attribute "dep" string "positions"' write(11,*) 'object "irregular positions irregular connections" class field' write(11,*) 'component "positions" value 1' @@ -784,20 +784,20 @@ program create_movie_AVS_DX ! end of test for GMT format endif - if(.not. UNIQUE_FILE) close(11) + if (.not. UNIQUE_FILE) close(11) ! end of loop and test on all the time steps for all the movie images endif enddo - if(UNIQUE_FILE) close(11) + if (UNIQUE_FILE) close(11) print * print *,'done creating movie or shaking map' print * - if(USE_OPENDX) print *,'DX files are stored in OUTPUT_FILES/DX_*.dx' - if(USE_AVS) print *,'AVS files are stored in OUTPUT_FILES/AVS_*.inp' - if(USE_GMT) then + if (USE_OPENDX) print *,'DX files are stored in OUTPUT_FILES/DX_*.dx' + if (USE_AVS) print *,'AVS files are stored in OUTPUT_FILES/AVS_*.inp' + if (USE_GMT) then print *,'GMT files are stored in OUTPUT_FILES/gmt_*.xyz' print * print *,'number of points in longitude in GMT grid = ',NEX_XI+1 @@ -871,9 +871,9 @@ subroutine get_global_AVS(nspec,xp,yp,zp,iglob,loc,ifseg,nglob,npointot,UTM_X_MI ! sort within each segment ioff=1 do iseg=1,nseg - if(j == 1) then + if (j == 1) then call rank(xp(ioff),ind,ninseg(iseg)) - else if(j == 2) then + else if (j == 2) then call rank(yp(ioff),ind,ninseg(iseg)) else call rank(zp(ioff),ind,ninseg(iseg)) @@ -884,24 +884,24 @@ subroutine get_global_AVS(nspec,xp,yp,zp,iglob,loc,ifseg,nglob,npointot,UTM_X_MI ! check for jumps in current coordinate ! compare the coordinates of the points within a small tolerance - if(j == 1) then + if (j == 1) then do i=2,npointot - if(dabs(xp(i)-xp(i-1)) > SMALLVALTOL) ifseg(i)=.true. + if (dabs(xp(i)-xp(i-1)) > SMALLVALTOL) ifseg(i)=.true. enddo - else if(j == 2) then + else if (j == 2) then do i=2,npointot - if(dabs(yp(i)-yp(i-1)) > SMALLVALTOL) ifseg(i)=.true. + if (dabs(yp(i)-yp(i-1)) > SMALLVALTOL) ifseg(i)=.true. enddo else do i=2,npointot - if(dabs(zp(i)-zp(i-1)) > SMALLVALTOL) ifseg(i)=.true. + if (dabs(zp(i)-zp(i-1)) > SMALLVALTOL) ifseg(i)=.true. enddo endif ! count up number of different segments nseg=0 do i=1,npointot - if(ifseg(i)) then + if (ifseg(i)) then nseg=nseg+1 ninseg(nseg)=1 else @@ -913,7 +913,7 @@ subroutine get_global_AVS(nspec,xp,yp,zp,iglob,loc,ifseg,nglob,npointot,UTM_X_MI ! assign global node numbers (now sorted lexicographically) ig=0 do i=1,npointot - if(ifseg(i)) ig=ig+1 + if (ifseg(i)) ig=ig+1 iglob(loc(i))=ig enddo @@ -952,8 +952,8 @@ subroutine rank(A,IND,N) L=n/2+1 ir=n - 100 CONTINUE - IF (l>1) THEN + 100 continue + if (l>1) then l=l-1 indx=ind(l) q=a(indx) @@ -969,12 +969,12 @@ subroutine rank(A,IND,N) endif i=l j=l+l - 200 CONTINUE - IF (J <= IR) THEN - IF (J 0) then + if (iboolleft_xi(npoin2D_xi) > 0) then npoin2D_xi = npoin2D_xi + 1 goto 350 endif @@ -70,7 +70,7 @@ subroutine read_arrays_buffers_solver(myrank, & npoin2D_xi = npoin2D_xi - 1 ! read nb of points given by the mesher read(IIN,*) npoin2D_xi_mesher - if(npoin2D_xi > NPOIN2DMAX_XMIN_XMAX .or. npoin2D_xi /= npoin2D_xi_mesher) & + if (npoin2D_xi > NPOIN2DMAX_XMIN_XMAX .or. npoin2D_xi /= npoin2D_xi_mesher) & call exit_MPI(myrank,'incorrect iboolleft_xi read') close(IIN) @@ -79,7 +79,7 @@ subroutine read_arrays_buffers_solver(myrank, & npoin2D_xi = 1 360 continue read(IIN,*) iboolright_xi(npoin2D_xi),xdummy,ydummy,zdummy - if(iboolright_xi(npoin2D_xi) > 0) then + if (iboolright_xi(npoin2D_xi) > 0) then npoin2D_xi = npoin2D_xi + 1 goto 360 endif @@ -87,11 +87,11 @@ subroutine read_arrays_buffers_solver(myrank, & npoin2D_xi = npoin2D_xi - 1 ! read nb of points given by the mesher read(IIN,*) npoin2D_xi_mesher - if(npoin2D_xi > NPOIN2DMAX_XMIN_XMAX .or. npoin2D_xi /= npoin2D_xi_mesher) & + if (npoin2D_xi > NPOIN2DMAX_XMIN_XMAX .or. npoin2D_xi /= npoin2D_xi_mesher) & call exit_MPI(myrank,'incorrect iboolright_xi read') close(IIN) - if(myrank == 0) then + if (myrank == 0) then write(IMAIN,*) write(IMAIN,*) '# of points in MPI buffers along xi npoin2D_xi = ', & npoin2D_xi @@ -109,7 +109,7 @@ subroutine read_arrays_buffers_solver(myrank, & npoin2D_eta = 1 370 continue read(IIN,*) iboolleft_eta(npoin2D_eta),xdummy,ydummy,zdummy - if(iboolleft_eta(npoin2D_eta) > 0) then + if (iboolleft_eta(npoin2D_eta) > 0) then npoin2D_eta = npoin2D_eta + 1 goto 370 endif @@ -117,7 +117,7 @@ subroutine read_arrays_buffers_solver(myrank, & npoin2D_eta = npoin2D_eta - 1 ! read nb of points given by the mesher read(IIN,*) npoin2D_eta_mesher - if(npoin2D_eta > NPOIN2DMAX_YMIN_YMAX .or. npoin2D_eta /= npoin2D_eta_mesher) & + if (npoin2D_eta > NPOIN2DMAX_YMIN_YMAX .or. npoin2D_eta /= npoin2D_eta_mesher) & call exit_MPI(myrank,'incorrect iboolleft_eta read') close(IIN) @@ -126,7 +126,7 @@ subroutine read_arrays_buffers_solver(myrank, & npoin2D_eta = 1 380 continue read(IIN,*) iboolright_eta(npoin2D_eta),xdummy,ydummy,zdummy - if(iboolright_eta(npoin2D_eta) > 0) then + if (iboolright_eta(npoin2D_eta) > 0) then npoin2D_eta = npoin2D_eta + 1 goto 380 endif @@ -134,11 +134,11 @@ subroutine read_arrays_buffers_solver(myrank, & npoin2D_eta = npoin2D_eta - 1 ! read nb of points given by the mesher read(IIN,*) npoin2D_eta_mesher - if(npoin2D_eta > NPOIN2DMAX_YMIN_YMAX .or. npoin2D_eta /= npoin2D_eta_mesher) & + if (npoin2D_eta > NPOIN2DMAX_YMIN_YMAX .or. npoin2D_eta /= npoin2D_eta_mesher) & call exit_MPI(myrank,'incorrect iboolright_eta read') close(IIN) - if(myrank == 0) then + if (myrank == 0) then write(IMAIN,*) write(IMAIN,*) '# of points in MPI buffers along eta npoin2D_eta = ', & npoin2D_eta diff --git a/utils/unused_routines/read_arrays_solver.f90 b/utils/unused_routines/read_arrays_solver.f90 index 67582b68c..a748e95c4 100644 --- a/utils/unused_routines/read_arrays_solver.f90 +++ b/utils/unused_routines/read_arrays_solver.f90 @@ -166,7 +166,7 @@ subroutine read_arrays_solver(myrank,NSPEC_AB,NGLOB_AB,xstore,ystore,zstore, & close(IIN) ! read additional ocean load mass matrix - if(OCEANS) then + if (OCEANS) then open(unit=IIN,file=prname(1:len_trim(prname))//'rmass_ocean_load.bin',status='old',action='read',form='unformatted') read(IIN) rmass_ocean_load close(IIN) @@ -208,7 +208,7 @@ subroutine read_arrays_solver(myrank,NSPEC_AB,NGLOB_AB,xstore,ystore,zstore, & read(IIN) mustore close(IIN) - if(ANISOTROPY) then + if (ANISOTROPY) then ! c11 open(unit=IIN,file=prname(1:len_trim(prname))//'c11.bin',status='old',action='read',form='unformatted') diff --git a/utils/unused_routines/salton_trough_gocad.f90 b/utils/unused_routines/salton_trough_gocad.f90 index d115a9c46..7f3f46662 100644 --- a/utils/unused_routines/salton_trough_gocad.f90 +++ b/utils/unused_routines/salton_trough_gocad.f90 @@ -117,7 +117,7 @@ subroutine vx_xyz_interp(uc,vc,wc, vp, vs, rho, vp_array) (v5 - GOCAD_ST_NO_DATA_VALUE) > eps .and. & (v6 - GOCAD_ST_NO_DATA_VALUE) > eps .and. & (v7 - GOCAD_ST_NO_DATA_VALUE) > eps .and. & - (v8 - GOCAD_ST_NO_DATA_VALUE) > eps ) then + (v8 - GOCAD_ST_NO_DATA_VALUE) > eps ) then vp = dble(& v1 * (1-xi) * (1-eta) * (1-ga) +& v2 * xi * (1-eta) * (1-ga) +& @@ -149,7 +149,7 @@ subroutine vx_xyz_interp(uc,vc,wc, vp, vs, rho, vp_array) vp = GOCAD_ST_NO_DATA_VALUE endif zmesh = wc / (GOCAD_ST_NW - 1) * GOCAD_ST_W_Z + GOCAD_ST_O_Z - if (zmesh > -8500.) then + if (zmesh > -8500.) then vs = vp / (2 - (0.27*zmesh/(-8500))) else vs = vp/1.73 diff --git a/utils/unused_routines/save_moho_arrays.f90 b/utils/unused_routines/save_moho_arrays.f90 index c558bd954..9e4dfc130 100644 --- a/utils/unused_routines/save_moho_arrays.f90 +++ b/utils/unused_routines/save_moho_arrays.f90 @@ -183,7 +183,7 @@ subroutine save_moho_arrays( myrank,nglob,nspec, & iglob = ibool(i,j,k,ispec) ! checks if point on surface - if( iglob_is_surface(iglob) > 0 ) then + if ( iglob_is_surface(iglob) > 0 ) then counter = counter+1 ! reference corner coordinates @@ -194,7 +194,7 @@ subroutine save_moho_arrays( myrank,nglob,nspec, & enddo ! stores moho informations - if( counter == NGNOD2D ) then + if ( counter == NGNOD2D ) then ! gets face GLL points i,j,k indices from element face call get_element_face_gll_indices(iface,ijk_face,NGLLX,NGLLY) @@ -235,10 +235,10 @@ subroutine save_moho_arrays( myrank,nglob,nspec, & ispec2D = iglob_is_surface(iglob_midpoint) ! sets face infos for bottom (normal points away from element) - if( idirect == 1 ) then + if ( idirect == 1 ) then ! checks validity - if( is_moho_bot( ispec) .eqv. .true. ) then + if ( is_moho_bot( ispec) .eqv. .true. ) then print *,'error: moho surface geometry bottom' print *,' does not allow for mulitple element faces in kernel computation' call exit_mpi(myrank,'error moho bottom elements') @@ -259,10 +259,10 @@ subroutine save_moho_arrays( myrank,nglob,nspec, & enddo ! sets face infos for top element - else if( idirect == 2 ) then + else if ( idirect == 2 ) then ! checks validity - if( is_moho_top( ispec) .eqv. .true. ) then + if ( is_moho_top( ispec) .eqv. .true. ) then print *,'error: moho surface geometry top' print *,' does not allow for mulitple element faces kernel computation' call exit_mpi(myrank,'error moho top elements') @@ -289,7 +289,7 @@ subroutine save_moho_arrays( myrank,nglob,nspec, & enddo ! iface ! checks validity of top/bottom distinction - if( is_moho_top(ispec) .and. is_moho_bot(ispec) ) then + if ( is_moho_top(ispec) .and. is_moho_bot(ispec) ) then print *,'error: moho surface elements confusing' print *,' element:',ispec,'has top and bottom surface' call exit_mpi(myrank,'error moho surface element') @@ -302,7 +302,7 @@ subroutine save_moho_arrays( myrank,nglob,nspec, & call sum_all_i( imoho_top, imoho_top_all ) call sum_all_i( imoho_bot, imoho_bot_all ) call sum_all_i( NSPEC2D_MOHO, imoho_all ) - if( myrank == 0 ) then + if ( myrank == 0 ) then write(IMAIN,*) '********' write(IMAIN,*) 'Moho surface:' write(IMAIN,*) ' total surface elements: ',imoho_all diff --git a/utils/unused_routines/socal_model.f90 b/utils/unused_routines/socal_model.f90 index 2b754e169..1a0578d60 100644 --- a/utils/unused_routines/socal_model.f90 +++ b/utils/unused_routines/socal_model.f90 @@ -34,17 +34,17 @@ subroutine socal_model(idoubling,rho,vp,vs) integer idoubling double precision rho,vp,vs - if(idoubling == IFLAG_HALFSPACE_MOHO) then + if (idoubling == IFLAG_HALFSPACE_MOHO) then vp=7.8d0 vs=4.5d0 rho=3.0d0 - else if(idoubling == IFLAG_MOHO_16km) then + else if (idoubling == IFLAG_MOHO_16km) then vp=6.7d0 vs=3.87d0 rho=2.8d0 - else if(idoubling == IFLAG_ONE_LAYER_TOPOGRAPHY .or. idoubling == IFLAG_BASEMENT_TOPO) then + else if (idoubling == IFLAG_ONE_LAYER_TOPOGRAPHY .or. idoubling == IFLAG_BASEMENT_TOPO) then vp=5.5d0 vs=3.18d0 rho=2.4d0 diff --git a/utils/unused_routines/source_models/convert_Rob_Graves_Northridge/convert_raw_files_Graves_horizontal.f90 b/utils/unused_routines/source_models/convert_Rob_Graves_Northridge/convert_raw_files_Graves_horizontal.f90 index 4d7526db2..39e24edda 100644 --- a/utils/unused_routines/source_models/convert_Rob_Graves_Northridge/convert_raw_files_Graves_horizontal.f90 +++ b/utils/unused_routines/source_models/convert_Rob_Graves_Northridge/convert_raw_files_Graves_horizontal.f90 @@ -26,7 +26,7 @@ program convert_raw_files_Wald numarg = iargc() - if(numarg /= 3) stop 'need exactly 3 arguments' + if (numarg /= 3) stop 'need exactly 3 arguments' ! get the 3 arguments call getarg(1,arg1) @@ -50,8 +50,8 @@ program convert_raw_files_Wald close(11) !! DK DK particular case of 360 degree angle - if(iangle1 == 360) iangle1 = 0 - if(iangle2 == 360) iangle2 = 0 + if (iangle1 == 360) iangle1 = 0 + if (iangle2 == 360) iangle2 = 0 write(*,*) write(*,*) arg1,arg2,arg3 @@ -112,8 +112,8 @@ program convert_raw_files_Wald ! swap components if needed, if angles are inverted on command line itarget_angle = iangle1 - 90 - if(itarget_angle < 0) itarget_angle = itarget_angle + 360 - if(iangle2 /= itarget_angle) then + if (itarget_angle < 0) itarget_angle = itarget_angle + 360 + if (iangle2 /= itarget_angle) then print *,'swapping components **************' ianglebak = iangle1 amplitudebak = amplitude1 @@ -128,8 +128,8 @@ program convert_raw_files_Wald ! now check that angles are always correct write(*,*) iangle1,iangle2 itarget_angle = iangle1 - 90 - if(itarget_angle < 0) itarget_angle = itarget_angle + 360 - if(iangle2 /= itarget_angle) stop 'difference of angles is not 90 degrees' + if (itarget_angle < 0) itarget_angle = itarget_angle + 360 + if (iangle2 /= itarget_angle) stop 'difference of angles is not 90 degrees' !! DK DK rotation from Rob Graves' azimuth to SEM East/North/up convention rotation_angle = - (90 - iangle1) * PI / 180.d0 diff --git a/utils/unused_routines/source_models/convert_finite_sources/convert_ASCII_tsurf_to_CMTSOLUTION.f90 b/utils/unused_routines/source_models/convert_finite_sources/convert_ASCII_tsurf_to_CMTSOLUTION.f90 index 369db7d10..550d893ec 100644 --- a/utils/unused_routines/source_models/convert_finite_sources/convert_ASCII_tsurf_to_CMTSOLUTION.f90 +++ b/utils/unused_routines/source_models/convert_finite_sources/convert_ASCII_tsurf_to_CMTSOLUTION.f90 @@ -128,15 +128,15 @@ program convert_tsurf_to_CMTSOLUTION read(5,*) event_number - if(event_number == 1) then + if (event_number == 1) then SIGN_NORMAL = +1 tsurf_file = 'ASCII_1857_rupture_remeshed.dat' - else if(event_number == 2) then + else if (event_number == 2) then SIGN_NORMAL = -1 tsurf_file = 'ASCII_whittier_remeshed.dat' - else if(event_number == 3) then + else if (event_number == 3) then SIGN_NORMAL = -1 tsurf_file = 'ASCII_southern_san_andreas_remeshed.dat' @@ -222,7 +222,7 @@ program convert_tsurf_to_CMTSOLUTION exclude_source = .false. ! exclude if horizontal coordinates are outside the block - if(lat <= LAT_MIN + TOLERANCE .or. lat >= LAT_MAX - TOLERANCE .or. & + if (lat <= LAT_MIN + TOLERANCE .or. lat >= LAT_MAX - TOLERANCE .or. & long <= LONG_MIN + TOLERANCE .or. long >= LONG_MAX - TOLERANCE .or. & z_center_triangle <= - dabs(DEPTH_BLOCK_KM*1000.d0)) & exclude_source = .true. @@ -234,10 +234,10 @@ program convert_tsurf_to_CMTSOLUTION icornerlat = int((lat - ORIG_LAT_TOPO) / DEGREES_PER_CELL_TOPO) + 1 ! avoid edge effects and extend with identical point if outside model - if(icornerlong < 1) icornerlong = 1 - if(icornerlong > NX_TOPO-1) icornerlong = NX_TOPO-1 - if(icornerlat < 1) icornerlat = 1 - if(icornerlat > NY_TOPO-1) icornerlat = NY_TOPO-1 + if (icornerlong < 1) icornerlong = 1 + if (icornerlong > NX_TOPO-1) icornerlong = NX_TOPO-1 + if (icornerlat < 1) icornerlat = 1 + if (icornerlat > NY_TOPO-1) icornerlat = NY_TOPO-1 ! compute coordinates of corner long_corner = ORIG_LONG_TOPO + (icornerlong-1)*DEGREES_PER_CELL_TOPO @@ -248,10 +248,10 @@ program convert_tsurf_to_CMTSOLUTION ratio_eta = (lat - lat_corner) / DEGREES_PER_CELL_TOPO ! avoid edge effects - if(ratio_xi < 0.) ratio_xi = 0. - if(ratio_xi > 1.) ratio_xi = 1. - if(ratio_eta < 0.) ratio_eta = 0. - if(ratio_eta > 1.) ratio_eta = 1. + if (ratio_xi < 0.) ratio_xi = 0. + if (ratio_xi > 1.) ratio_xi = 1. + if (ratio_eta < 0.) ratio_eta = 0. + if (ratio_eta > 1.) ratio_eta = 1. ! interpolate elevation at current point elevation = & @@ -260,11 +260,11 @@ program convert_tsurf_to_CMTSOLUTION itopo_bathy_basin(icornerlong+1,icornerlat+1)*ratio_xi*ratio_eta + & itopo_bathy_basin(icornerlong,icornerlat+1)*(1.-ratio_xi)*ratio_eta - if(z_center_triangle > elevation - DEPTH_REMOVED_TOPO) & + if (z_center_triangle > elevation - DEPTH_REMOVED_TOPO) & exclude_source = .true. ! store current point if source is kept - if(.not. exclude_source) then + if (.not. exclude_source) then isource = isource + 1 iglob1_copy(isource) = iglob1(isource_current) iglob2_copy(isource) = iglob2(isource_current) @@ -368,7 +368,7 @@ program convert_tsurf_to_CMTSOLUTION time_shift = dsqrt((x_center_triangle-x_begin)**2 + (y_center_triangle-y_begin)**2) / rupture_velocity ! store source with minimum time shift for reference - if(time_shift < time_shift_min) isourceshiftmin = isource + if (time_shift < time_shift_min) isourceshiftmin = isource time_shift_min = dmin1(time_shift_min,time_shift) time_shift_max = dmax1(time_shift_max,time_shift) @@ -382,7 +382,7 @@ program convert_tsurf_to_CMTSOLUTION print * ! making sure that minimum time shift is set for source #1 - if(isourceshiftmin /= 1) then + if (isourceshiftmin /= 1) then iglob1_store = iglob1_copy(1) iglob2_store = iglob2_copy(1) iglob3_store = iglob3_copy(1) @@ -400,7 +400,7 @@ program convert_tsurf_to_CMTSOLUTION ! read slip distribution from Sieh (1978) if San Andreas 1857 ! convert horizontal distance from km to m - if(event_number == 1) then + if (event_number == 1) then print *,'reading slip ditribution from Sieh (1978)' open(unit=11,file='DATA/slip_sieh_1857_extracted.txt',status='old') do ipoin = 1,NPOIN_SIEH_1978 @@ -459,8 +459,8 @@ program convert_tsurf_to_CMTSOLUTION ny = SIGN_NORMAL * ny / norm nz = SIGN_NORMAL * nz / norm !! DK DK fix problem of different normals for Southern San Andreas - if(event_number == 3) then - if(ny < 0.) then + if (event_number == 3) then + if (ny < 0.) then nx = - nx ny = - ny nz = - nz @@ -483,14 +483,14 @@ program convert_tsurf_to_CMTSOLUTION ! avoid null values when two points are aligned on the same vertical ! by choosing the edge with the longest projection along X - if(dabs(x3-x1) > horizdistval) then + if (dabs(x3-x1) > horizdistval) then ex = x3-x1 ey = y3-y1 ez = z3-z1 horizdistval = dabs(ex) endif - if(dabs(x3-x2) > horizdistval) then + if (dabs(x3-x2) > horizdistval) then ex = x3-x2 ey = y3-y2 ez = z3-z2 @@ -499,7 +499,7 @@ program convert_tsurf_to_CMTSOLUTION ! because of fault orientation, slip should always be from East to West !! DK DK UGLY check this, could be the other way around - if(ex > 0.) then + if (ex > 0.) then ex = - ex ey = - ey ez = - ez @@ -507,13 +507,13 @@ program convert_tsurf_to_CMTSOLUTION ! test of slip vector orientation for right-lateral strike-slip !! DK DK UGLY check this, could be the other way around -!! DK DK UGLY fix this tomorrow if(ex > 0. .or. ey < 0.) stop 'wrong orientation of slip vector' +!! DK DK UGLY fix this tomorrow if (ex > 0. .or. ey < 0.) stop 'wrong orientation of slip vector' ! make sure slip is horizontal (for strike-slip) ez = 0. ! determine slip length from Sieh (1978) if SAF 1857, use constant otherwise - if(event_number /= 1) then + if (event_number /= 1) then real_slip_length = AVERAGE_SLIP_LENGTH @@ -527,7 +527,7 @@ program convert_tsurf_to_CMTSOLUTION do ipoin = 1,NPOIN_SIEH_1978 ! distance to current point in Sieh (1978) scanned curved dist_sieh = dabs(xslip_sieh_1978(ipoin) - horiz_dist_fault) - if(dist_sieh < min_dist) then + if (dist_sieh < min_dist) then min_dist = dist_sieh index_min_dist = ipoin endif @@ -560,11 +560,11 @@ program convert_tsurf_to_CMTSOLUTION time_shift = dsqrt((x_center_triangle-x_begin)**2 + (y_center_triangle-y_begin)**2) / rupture_velocity ! store source with minimum time shift for reference - if(time_shift < time_shift_min) isourceshiftmin = isource + if (time_shift < time_shift_min) isourceshiftmin = isource time_shift_min = dmin1(time_shift_min,time_shift) time_shift_max = dmax1(time_shift_max,time_shift) - if(isource == 1) then + if (isource == 1) then write(11,"('time shift: 0')") else write(11,"('time shift: ',e)") time_shift @@ -626,7 +626,7 @@ program convert_tsurf_to_CMTSOLUTION print *,'time shift min max (s) = ',time_shift_min,time_shift_max print *,'minimum time shift was detected for new source ',isourceshiftmin print *,'and was automatically set to exactly zero' - if(isourceshiftmin /= 1) stop 'minimum time shift should be for first source' + if (isourceshiftmin /= 1) stop 'minimum time shift should be for first source' print * print *,'You need to set NSOURCES = ',NSOURCES,' in DATA/Par_file' @@ -701,8 +701,8 @@ program convert_tsurf_to_CMTSOLUTION ny = SIGN_NORMAL * ny / norm nz = SIGN_NORMAL * nz / norm !! DK DK fix problem of different normals for Southern San Andreas - if(event_number == 3) then - if(ny < 0.) then + if (event_number == 3) then + if (ny < 0.) then nx = - nx ny = - ny nz = - nz @@ -762,7 +762,7 @@ program convert_tsurf_to_CMTSOLUTION call utm_geo(long,lat,x_center_triangle,y_center_triangle,UTM_PROJECTION_ZONE) ! use different color depending on whether the source is inside the basin model - if(lat <= LAT_MIN + TOLERANCE .or. lat >= LAT_MAX - TOLERANCE .or. & + if (lat <= LAT_MIN + TOLERANCE .or. lat >= LAT_MAX - TOLERANCE .or. & long <= LONG_MIN + TOLERANCE .or. long >= LONG_MAX - TOLERANCE .or. & z_center_triangle <= - dabs(DEPTH_BLOCK_KM*1000.d0)) then write(11,*) '200' diff --git a/utils/unused_routines/source_models/convert_finite_sources/convert_CMT_psmeca_format.f90 b/utils/unused_routines/source_models/convert_finite_sources/convert_CMT_psmeca_format.f90 index edb8a1fc1..f977bac58 100644 --- a/utils/unused_routines/source_models/convert_finite_sources/convert_CMT_psmeca_format.f90 +++ b/utils/unused_routines/source_models/convert_finite_sources/convert_CMT_psmeca_format.f90 @@ -20,12 +20,12 @@ program convert_CMT_psmeca_format ! header of script write(*,8) - if(ichoice == SAF_1857) then + if (ichoice == SAF_1857) then ! NLINES = 14118 !! DK DK real value NLINES = 3000 !! DK DK use only part of the file scaleval = 1.d14 write(*,*) 'psbasemap -R-124/-114/30/40 -JM15c -Bf1a2:Distance:/:"samples":WeSn -K > f1.ps' - else if(ichoice == NORTHRIDGE) then + else if (ichoice == NORTHRIDGE) then NLINES = 196 scaleval = 1.d24 write(*,*) 'psbasemap -R-120/-116/32/36 -JM15c -Bf1a2:Distance:/:"samples":WeSn -K > f1.ps' @@ -88,14 +88,14 @@ program convert_CMT_psmeca_format Mtp = Mtp / scaleval !! DK DK need to remove the last -K in output file - if(iline < NLINES) then - if(ichoice == SAF_1857) then + if (iline < NLINES) then + if (ichoice == SAF_1857) then write(*,100) long,lat,depth,mrr,mtt,mpp,mrt,mrp,mtp else write(*,200) long,lat,depth,mrr,mtt,mpp,mrt,mrp,mtp endif else - if(ichoice == SAF_1857) then + if (ichoice == SAF_1857) then write(*,110) long,lat,depth,mrr,mtt,mpp,mrt,mrp,mtp else write(*,210) long,lat,depth,mrr,mtt,mpp,mrt,mrp,mtp diff --git a/utils/unused_routines/source_models/convert_finite_sources/convert_Wald_CMTSOLUTION_Northridge.f90 b/utils/unused_routines/source_models/convert_finite_sources/convert_Wald_CMTSOLUTION_Northridge.f90 index 4ee367053..8513cd486 100644 --- a/utils/unused_routines/source_models/convert_finite_sources/convert_Wald_CMTSOLUTION_Northridge.f90 +++ b/utils/unused_routines/source_models/convert_finite_sources/convert_Wald_CMTSOLUTION_Northridge.f90 @@ -181,7 +181,7 @@ program convert_northridge_CMT time_shift = distance_hypo / RUPTURE_VELOCITY ! compute and locate minimum time shift - if(time_shift < timeshift_min) then + if (time_shift < timeshift_min) then timeshift_min = time_shift ix_time_min = ix iy_time_min = iy @@ -237,7 +237,7 @@ program convert_northridge_CMT ! ierr error indicator (OUTPUT) ierr = 0 call pl2nd(strike,dip,rake,anx,any,anz,dx,dy,dz,ierr) - if(ierr /= 0) stop 'error in pl2nd conversion' + if (ierr /= 0) stop 'error in pl2nd conversion' ! compute moment tensor Cartesian components (Harvard CMT convention) @@ -254,7 +254,7 @@ program convert_northridge_CMT ierr = 0 am0 = scalar_moment_patch call nd2ha(anx,any,anz,dx,dy,dz,am0,am,ierr) - if(ierr /= 0) stop 'error in nd2ha conversion' + if (ierr /= 0) stop 'error in nd2ha conversion' !! DK DK compute longitude and depth of this point in the fault plane !! DK DK use bilinear interpolation from the four corners of the fault @@ -287,7 +287,7 @@ program convert_northridge_CMT write(11,"(a)") 'event name: 9903873' ! time shift - if(ix == ix_time_min .and. iy == iy_time_min) then + if (ix == ix_time_min .and. iy == iy_time_min) then write(11,"('time shift: 0')") else write(11,"('time shift: ',e)") time_shift @@ -381,15 +381,15 @@ subroutine pl2nd(strike,dip,rake,anx,any,anz,dx,dy,dz,ierr) dy=c0 dz=c0 ierr=0 - if(strikeamastr) then + if (strikeamastr) then write(io,'(1x,a,g10.4,a)') 'PL2ND: input STRIKE angle ',strike, & ' out of range' ierr=1 endif - if(dipamadip) then - if(dip-ovrtol) then + if (dipamadip) then + if (dip-ovrtol) then dip=amidip - else if(dip>amidip.and.dip-amadipamidip.and.dip-amadipamarak) then + if (rakeamarak) then write(io,'(1x,a,g10.4,a)') 'PL2ND: input RAKE angle ',rake, & ' out of range' ierr=ierr+4 endif - if(ierr/=0) return + if (ierr/=0) return wstrik=strike*dtor wdip=dip*dtor wrake=rake*dtor @@ -456,19 +456,19 @@ subroutine nd2pl(wanx,wany,wanz,wdx,wdy,wdz,phi,delta,alam,dipdir & ! ierr=0 call angle(wanx,wany,wanz,wdx,wdy,wdz,ang) - if(abs(ang-c90)>orttol) then + if (abs(ang-c90)>orttol) then write(io,'(1x,a,g15.7,a)') 'ND2PL: input vectors not ' & //'perpendicular, angle=',ang ierr=1 endif call norm(wanx,wany,wanz,anorm,anx,any,anz) call norm(wdx,wdy,wdz,dnorm,dx,dy,dz) - if(anz>c0) then + if (anz>c0) then call invert(anx,any,anz) call invert(dx,dy,dz) endif ! - if(anz==-c1) then + if (anz==-c1) then wdelta=c0 wphi=c0 walam=atan2(-dy,dx) @@ -523,15 +523,15 @@ subroutine ax2ca(trend,plunge,ax,ay,az,ierr) ay=c0 az=c0 ierr=0 - if(trendamatre) then + if (trendamatre) then write(io,'(1x,a,g10.4,a)') 'AX2CA: input TREND angle ',trend, & ' out of range' ierr=1 endif - if(plungeamaplu) then - if(plunge-ovrtol) then + if (plungeamaplu) then + if (plunge-ovrtol) then plunge=amiplu - else if(plunge>amiplu.and.plunge-amapluamiplu.and.plunge-amapluorttol) then + if (abs(ang-c90)>orttol) then write(io,'(1x,a,g15.7,a)') 'PT2ND: input vectors not ' & //'perpendicular, angle=',ang ierr=1 endif call norm(wpx,wpy,wpz,pnorm,px,py,pz) - if(pzc0) then + if (anz>c0) then call invert(anx,any,anz) call invert(dx,dy,dz) endif @@ -704,7 +704,7 @@ subroutine nd2pt(wanx,wany,wanz,wdx,wdy,wdz,px,py,pz,tx,ty,tz,bx & call norm(wanx,wany,wanz,amn,anx,any,anz) call norm(wdx,wdy,wdz,amd,dx,dy,dz) call angle(anx,any,anz,dx,dy,dz,ang) - if(abs(ang-c90)>orttol) then + if (abs(ang-c90)>orttol) then write(io,'(1x,a,g15.7,a)') 'ND2PT: input vectors not ' & //'perpendicular, angle=',ang ierr=1 @@ -713,14 +713,14 @@ subroutine nd2pt(wanx,wany,wanz,wdx,wdy,wdz,px,py,pz,tx,ty,tz,bx & py=any-dy pz=anz-dz call norm(px,py,pz,amp,px,py,pz) - if(pztentol) then + if (abs(am(1,2)-am(2,1))>tentol) then write(io,'(1x,a,g10.4,a,g10.4)') 'AR2PT: input tensor not' & //' symmetrical, m(1,2)=',am(1,2),' m(2,1)=',am(2,1) ierr=1 endif - if(abs(am(1,3)-am(3,1))>tentol) then + if (abs(am(1,3)-am(3,1))>tentol) then write(io,'(1x,a,g10.4,a,g10.4)') 'AR2PT: input tensor not' & //' symmetrical, m(1,3)=',am(1,3),' m(3,1)=',am(3,1) ierr=ierr+2 endif - if(abs(am(3,2)-am(2,3))>tentol) then + if (abs(am(3,2)-am(2,3))>tentol) then write(io,'(1x,a,g10.4,a,g10.4)') 'AR2PT: input tensor not' & //' symmetrical, m(2,3)=',am(2,3),' m(3,2)=',am(3,2) ierr=ierr+4 endif - if(ierr/=0) return + if (ierr/=0) return call avec(am,val,vec) e=(val(1)+val(2)+val(3))/c3 ! @@ -815,7 +815,7 @@ subroutine ar2pt(am,am0,am1,e,am0b,px,py,pz,tx,ty,tz,bx,by,bz & ! do 2 i=1,2 do 3 j=i+1,3 - if(abs(val(i))orttol) then + if (abs(ang-c90)>orttol) then write(io,'(1x,a,g15.7,a)') 'ND2AR: input vectors not ' & //'perpendicular, angle=',ang ierr=1 @@ -956,22 +956,22 @@ subroutine ar2ha(am,amo,ierr) call fpsset ! ierr=0 - if(abs(am(1,2)-am(2,1))>tentol) then + if (abs(am(1,2)-am(2,1))>tentol) then write(io,'(1x,a,g10.4,a,g10.4)') 'AR2HA: input tensor not' & //' symmetrical, m(1,2)=',am(1,2),' m(2,1)=',am(2,1) ierr=1 endif - if(abs(am(1,3)-am(3,1))>tentol) then + if (abs(am(1,3)-am(3,1))>tentol) then write(io,'(1x,a,g10.4,a,g10.4)') 'AR2HA: input tensor not' & //' symmetrical, m(1,3)=',am(1,3),' m(3,1)=',am(3,1) ierr=ierr+2 endif - if(abs(am(3,2)-am(2,3))>tentol) then + if (abs(am(3,2)-am(2,3))>tentol) then write(io,'(1x,a,g10.4,a,g10.4)') 'AR2HA: input tensor not' & //' symmetrical, m(2,3)=',am(2,3),' m(3,2)=',am(3,2) ierr=ierr+4 endif - if(ierr/=0) then + if (ierr/=0) then do 1 i=1,3 do 2 j=1,3 amo(i,j)=c0 @@ -1036,12 +1036,12 @@ subroutine nd2ha(anx,any,anz,dx,dy,dz,am0,am,ierr) 1 continue ierr=0 call nd2ar(anx,any,anz,dx,dy,dz,am0,am,ierr) - if(ierr/=0) then + if (ierr/=0) then write(io,'(1x,a,i3)') 'ND2HA: ierr=',ierr return endif call ar2ha(am,am,ierr) - if(ierr/=0) then + if (ierr/=0) then ierr=2 write(io,'(1x,a,i3)') 'ND2HA: ierr=',ierr endif @@ -1093,12 +1093,12 @@ subroutine pl2pl(strika,dipa,rakea,strikb,dipb,rakeb, & call fpsset ! call pl2nd(strika,dipa,rakea,anx,any,anz,dx,dy,dz,ierr) - if(ierr/=0) then + if (ierr/=0) then write(io,'(1x,a,i3)') 'PL2PL: ierr=',ierr return endif call nd2pl(dx,dy,dz,anx,any,anz,strikb,dipb,rakeb,dipdib,ierr) - if(ierr/=0) then + if (ierr/=0) then ierr=8 write(io,'(1x,a,i3)') 'PL2PL: ierr=',ierr endif @@ -1152,27 +1152,27 @@ subroutine pl2pt(strike,dip,rake,trendp,plungp,trendt,plungt, & call fpsset ! call pl2nd(strike,dip,rake,anx,any,anz,dx,dy,dz,ierr) - if(ierr/=0) then + if (ierr/=0) then write(io,'(1x,a,i3)') 'PL2PT: ierr=',ierr return endif call nd2pt(dx,dy,dz,anx,any,anz,px,py,pz,tx,ty,tz,bx,by,bz,ierr) - if(ierr/=0) then + if (ierr/=0) then ierr=8 write(io,'(1x,a,i3)') 'PL2PT: ierr=',ierr endif call ca2ax(px,py,pz,trendp,plungp,ierr) - if(ierr/=0) then + if (ierr/=0) then ierr=9 write(io,'(1x,a,i3)') 'PL2PT: ierr=',ierr endif call ca2ax(tx,ty,tz,trendt,plungt,ierr) - if(ierr/=0) then + if (ierr/=0) then ierr=10 write(io,'(1x,a,i3)') 'PL2PT: ierr=',ierr endif call ca2ax(bx,by,bz,trendb,plungb,ierr) - if(ierr/=0) then + if (ierr/=0) then ierr=11 write(io,'(1x,a,i3)') 'PL2PT: ierr=',ierr endif @@ -1230,30 +1230,30 @@ subroutine pt2pl(trendp,plungp,trendt,plungt,strika,dipa,rakea & call fpsset ! call ax2ca(trendp,plungp,px,py,pz,ierr) - if(ierr/=0) then + if (ierr/=0) then write(io,'(1x,a,i3)') 'PT2PL: ierr=',ierr return endif call ax2ca(trendt,plungt,tx,ty,tz,ierr) - if(ierr/=0) then + if (ierr/=0) then ierr=ierr+3 write(io,'(1x,a,i3)') 'PT2PL: ierr=',ierr return endif call pt2nd(px,py,pz,tx,ty,tz,anx,any,anz,dx,dy,dz,ierr) - if(ierr/=0) then + if (ierr/=0) then ierr=8 write(io,'(1x,a,i3)') 'PT2PL: ierr=',ierr return endif call nd2pl(anx,any,anz,dx,dy,dz,strika,dipa,rakea,dipdia,ierr) - if(ierr/=0) then + if (ierr/=0) then ierr=9 write(io,'(1x,a,i3)') 'PT2PL: ierr=',ierr return endif call nd2pl(dx,dy,dz,anx,any,anz,strikb,dipb,rakeb,dipdib,ierr) - if(ierr/=0) then + if (ierr/=0) then ierr=10 write(io,'(1x,a,i3)') 'PT2PL: ierr=',ierr return @@ -1343,42 +1343,42 @@ subroutine ar2plp(am,am0,am1,e,am0b,phia,deltaa,alama,slipa, & plungb=c0 ierr=0 call ar2pt(am,am0,am1,e,am0b,px,py,pz,tx,ty,tz,bx,by,bz,eta,ierr) - if(ierr/=0) then + if (ierr/=0) then write(io,'(1x,a,i3)') 'AR2PLP: ierr=',ierr return endif call ca2ax(px,py,pz,trendp,plungp,ierr) - if(ierr/=0) then + if (ierr/=0) then ierr=5 write(io,'(1x,a,i3)') 'AR2PLP: ierr=',ierr return endif call ca2ax(tx,ty,tz,trendt,plungt,ierr) - if(ierr/=0) then + if (ierr/=0) then ierr=6 write(io,'(1x,a,i3)') 'AR2PLP: ierr=',ierr return endif call ca2ax(bx,by,bz,trendb,plungb,ierr) - if(ierr/=0) then + if (ierr/=0) then ierr=7 write(io,'(1x,a,i3)') 'AR2PLP: ierr=',ierr return endif call pt2nd(px,py,pz,tx,ty,tz,anx,any,anz,dx,dy,dz,ierr) - if(ierr/=0) then + if (ierr/=0) then ierr=8 write(io,'(1x,a,i3)') 'AR2PLP: ierr=',ierr return endif call nd2pl(anx,any,anz,dx,dy,dz,phia,deltaa,alama,slipa,ierr) - if(ierr/=0) then + if (ierr/=0) then ierr=9 write(io,'(1x,a,i3)') 'AR2PLP: ierr=',ierr return endif call nd2pl(dx,dy,dz,anx,any,anz,phib,deltab,alamb,slipb,ierr) - if(ierr/=0) then + if (ierr/=0) then ierr=10 write(io,'(1x,a,i3)') 'AR2PLP: ierr=',ierr return @@ -1466,14 +1466,14 @@ subroutine ha2plp(am,am0,am1,e,am0b,strika,dipa,rakea,slipa, & plungb=c0 ierr=0 call ar2ha(am,ama,ierr) - if(ierr/=0) then + if (ierr/=0) then write(io,'(1x,a,i3)') 'HA2PLP: ierr=',ierr return endif call ar2plp(ama,am0,am1,e,am0b,strika,dipa,rakea,slipa, & strikb,dipb,rakeb,slipb,trendp,plungp,trendt,plungt,trendb, & plungb,eta,ierr) - if(ierr/=0) then + if (ierr/=0) then write(io,'(1x,a,i3)') 'HA2PLP: ierr=',ierr endif return @@ -1526,12 +1526,12 @@ subroutine pl2ar(strike,dip,rake,am0,am,ierr) 1 continue ierr=0 call pl2nd(strike,dip,rake,anx,any,anz,dx,dy,dz,ierr) - if(ierr/=0) then + if (ierr/=0) then write(io,'(1x,a,i3)') 'PL2AR: ierr=',ierr return endif call nd2ar(anx,any,anz,dx,dy,dz,am0,am,ierr) - if(ierr/=0) then + if (ierr/=0) then ierr=8 write(io,'(1x,a,i3)') 'PL2AR: ierr=',ierr endif @@ -1585,12 +1585,12 @@ subroutine pl2ha(strike,dip,rake,am0,am,ierr) 1 continue ierr=0 call pl2ar(strike,dip,rake,am0,am,ierr) - if(ierr/=0) then + if (ierr/=0) then write(io,'(1x,a,i3)') 'PL2HA: ierr=',ierr return endif call ar2ha(am,am,ierr) - if(ierr/=0) then + if (ierr/=0) then ierr=9 write(io,'(1x,a,i3)') 'PL2HA: ierr=',ierr endif @@ -1646,24 +1646,24 @@ subroutine pt2ar(trendp,plungp,trendt,plungt,am0,am,ierr) 1 continue ierr=0 call ax2ca(trendp,plungp,px,py,pz,ierr) - if(ierr/=0) then + if (ierr/=0) then write(io,'(1x,a,i3)') 'PT2AR: ierr=',ierr return endif call ax2ca(trendt,plungt,tx,ty,tz,ierr) - if(ierr/=0) then + if (ierr/=0) then ierr=ierr+3 write(io,'(1x,a,i3)') 'PT2AR: ierr=',ierr return endif call pt2nd(px,py,pz,tx,ty,tz,anx,any,anz,dx,dy,dz,ierr) - if(ierr/=0) then + if (ierr/=0) then ierr=8 write(io,'(1x,a,i3)') 'PT2AR: ierr=',ierr return endif call nd2ar(anx,any,anz,dx,dy,dz,am0,am,ierr) - if(ierr/=0) then + if (ierr/=0) then ierr=9 write(io,'(1x,a,i3)') 'PT2AR: ierr=',ierr endif @@ -1718,12 +1718,12 @@ subroutine pt2ha(trendp,plungp,trendt,plungt,am0,am,ierr) 1 continue ierr=0 call pt2ar(trendp,plungp,trendt,plungt,am0,am,ierr) - if(ierr/=0) then + if (ierr/=0) then write(io,'(1x,a,i3)') 'PT2HA: ierr=',ierr return endif call ar2ha(am,am,ierr) - if(ierr/=0) then + if (ierr/=0) then ierr=10 write(io,'(1x,a,i3)') 'PT2HA: ierr=',ierr endif @@ -1758,7 +1758,7 @@ subroutine avec(am,eval,evec) stop 'DK DK CALL EVCSF (3, AM, 3, EVAL, EVEC, 3) not included, error' do 2 i=1,2 do 3 j=i+1,3 - if(abs(eval(i))