time_loop.f90

1D有限差分波动方程模拟

!=======================================================================

SUBROUTINE  TIME_LOOP

  USE CONTROL_DATA, ONLY:                                              &
                          MZ, MT1, MT2, LS,          KEY_TLD,          &
                                   KEY_SND, IPAS1, IPAS2, MR
  USE GRID_MEDIUM , ONLY:                                              &
                          H, DEN
  USE AUXIL       , ONLY:                                              &
                          SOURTF, NSTFS
  USE WAVEFIELD   , ONLY:                                              &
                          D, DM, SEIS
  USE TIME        , ONLY:                                              &
                          time_begin, time_end, DATE_TIME, BIG_BEN

!-----------------------------------------------------------------------

  IMPLICIT NONE

  LOGICAL :: EX, RECALL1D, RECALL2D
  INTEGER :: ITILMOD1, ITILMOD2, L, ITILE

!-----------------------------------------------------------------------

  INTERFACE

    SUBROUTINE     ANEL_FUNC
    END SUBROUTINE ANEL_FUNC
    
    SUBROUTINE     DISPLACEMENT (D,DM)
      USE PRECISION   , ONLY: WP
      USE CONTROL_DATA, ONLY: MZ
      IMPLICIT NONE
      REAL(WP), INTENT(INOUT), DIMENSION(0:MZ) :: D, DM
     END SUBROUTINE DISPLACEMENT
    
    SUBROUTINE     REC_DIS  (T,D)
      USE PRECISION   , ONLY: WP
      USE CONTROL_DATA, ONLY: MZ
      IMPLICIT NONE
      REAL(WP), INTENT(INOUT), DIMENSION(0:MZ) :: D
      INTEGER, INTENT(IN) :: T
    END SUBROUTINE REC_DIS
    
    SUBROUTINE     SNAP_DIS (T,D)
      USE PRECISION   , ONLY: WP
      USE CONTROL_DATA, ONLY: MZ
      IMPLICIT NONE
      REAL(WP), INTENT(INOUT), DIMENSION(0:MZ) :: D
      INTEGER, INTENT(IN) :: T
    END SUBROUTINE SNAP_DIS
    
    SUBROUTINE     STO_BOR (D)
      USE PRECISION   , ONLY: WP
      USE CONTROL_DATA, ONLY: MZ
      IMPLICIT NONE
      REAL(WP), INTENT(INOUT), DIMENSION(0:MZ) :: D
    END SUBROUTINE STO_BOR
    
    SUBROUTINE     STRAIN (D)
      USE PRECISION   , ONLY: WP
      USE CONTROL_DATA, ONLY: MZ
      IMPLICIT NONE
      REAL(WP), INTENT(INOUT), DIMENSION(0:MZ) :: D
    END SUBROUTINE STRAIN

    SUBROUTINE     STRESS
    END SUBROUTINE STRESS

  END INTERFACE   
  
!-----------------------------------------------------------------------

  CALL CPU_TIME ( time_begin )

  DO ITILE = MT1, MT2, 2
  
    CALL CPU_TIME ( time_end )
    CALL DATE_AND_TIME ( BIG_BEN(1),BIG_BEN(2),BIG_BEN(3), DATE_TIME )
    PRINT     *, 'CPU time: ', time_end - time_begin, ' seconds'
    WRITE (*,'(''Current time: '',I2,'':'',I2,'':'',F6.3)')              &
    DATE_TIME(5), DATE_TIME(6), DATE_TIME(7)+REAL(DATE_TIME(8)/1000.)
    PRINT     *, 'ITILE=', ITILE
    WRITE (11,'(I6,1X,F10.2,1X,I4,I3,I3,I5,3I3,I4)')                     &
               ITILE, time_end - time_begin, DATE_TIME

    CALL  STO_BOR      (D)
    CALL  STRAIN       (D)
    CALL  ANEL_FUNC
    CALL  STRESS
    CALL  DISPLACEMENT (D,DM)

    IF ( ITILE <= NSTFS ) THEN
      DM(LS) = DM(LS) + H*DEN(LS)*SOURTF(ITILE)
    END IF
    
    ITILMOD1 = MOD (ITILE,IPAS1)
    ITILMOD2 = MOD (ITILE,IPAS2)
    RECALL1D = KEY_TLD .AND. (ITILMOD1 == 0)
    RECALL2D = KEY_SND .AND. (ITILMOD2 == 0)

    IF ( RECALL1D ) CALL REC_DIS  (ITILE, DM)
    IF ( RECALL2D ) CALL SNAP_DIS (ITILE, DM)

!--------------- EVEN TIME LEVEL ---------------------

    CALL  STO_BOR      (DM)
    CALL  STRAIN       (DM)
    CALL  ANEL_FUNC
    CALL  STRESS
    CALL  DISPLACEMENT (DM,D)

    IF ( ITILE+1 <= NSTFS ) THEN
      D (LS) = D (LS) + H*DEN(LS)*SOURTF(ITILE+1)
    END IF
    
    ITILMOD1 = MOD (ITILE+1,IPAS1)
    ITILMOD2 = MOD (ITILE+1,IPAS2)
    RECALL1D = KEY_TLD .AND. (ITILMOD1 == 0)
    RECALL2D = KEY_SND .AND. (ITILMOD2 == 0)

    IF ( RECALL1D ) CALL REC_DIS  (ITILE+1, D )
    IF ( RECALL2D ) CALL SNAP_DIS (ITILE+1, D )

  END DO
 
  IF ( KEY_SND ) THEN
    DO L = 1, MR
      DO ITILE = 1, (MT2-MT1+1)/IPAS2
        WRITE ( 23, "(G10.4,2H, )" ) SEIS(L,ITILE)
      END DO
    END DO
    WRITE(23,*) "]"
    WRITE(23,*) "}"
    CLOSE(23)
  END IF


END  SUBROUTINE  TIME_LOOP