24小时热门版块排行榜

返回列表

吴兰特

新虫 (初入文坛)

应助: 0 (幼儿园)
金币: 90.5
帖子: 9
在线: 4.7小时
虫号: 4137373
注册: 2015-10-12
性别: GG
专业: 钢铁冶金

[求助] 有人能把这个程序运行下吗？或者给我解释下已有1人参与

!#############################################################
MODULE PARAM
!#############################################################
  INTEGER,PARAMETER    :: REAL_P = SELECTED_REAL_KIND(P=8,R=25)
  INTEGER,PARAMETER    :: NMAX=42
  INTEGER,PARAMETER    :: TMAX=200
  INTEGER,PARAMETER    :: RMAX=5
  INTEGER,PARAMETER    :: MMAX=5
END MODULE PARAM

!#############################################################
MODULE VAR
!#############################################################
  USE PARAM
  IMPLICIT NONE

  REAL(REAL_P), DIMENSION(NMAX) :: X,XC,R
  REAL(REAL_P), DIMENSION(NMAX) :: DEN
  REAL(REAL_P), DIMENSION(NMAX) :: CON
  REAL(REAL_P), DIMENSION(NMAX) :: CP
  REAL(REAL_P), DIMENSION(NMAX) :: T,TO,TOO,Z,ZO,ZOO
  REAL(REAL_P), DIMENSION(RMAX) :: KK
  REAL(REAL_P), DIMENSION(NMAX) :: AP,SU,AE,AW
  REAL(REAL_P), DIMENSION(NMAX) :: BPR,V

  REAL(REAL_P)                :: Q1,QN

  REAL(REAL_P)                :: TIN,DT,DTR,TIME,ERR,SOR
  INTEGER                      :: NTMAX,NI,NIM,NR,LMAX,NM
  INTEGER                      :: IK(MMAX)
  REAL(REAL_P)                :: Y(MMAX,RMAX)

END MODULE VAR

!#############################################################
SUBROUTINE GRID
!#############################################################
  USE VAR
  IMPLICIT NONE

  INTEGER       :: I,N
  REAL(REAL_P) :: EXP,DX,XMIN,XMAX
  OPEN(1,FILE='1dinv.inp')
  PRINT *,' ENTER: XMIN, XMAX, EXP. FACTOR, NUMBER OF NODES:  '
  READ(1,*) XMIN,XMAX,EXP,N

  NIM = N+1
  NI  = N+2

  IF(EXP.EQ.1.) THEN
DX=(XMAX-XMIN)/REAL(N)

  ELSE
DX=(XMAX-XMIN)*(1.-EXP)/(1.-EXP**N)
  ENDIF
!
  X(1)=XMIN
  DO I=2,NIM
X(I)=X(I-1)+DX
DX=DX*EXP
  END DO
  X(NI)=XMAX

  XC(1)=XMIN
  DO I=2,NIM
XC(I)=0.5*(X(I-1)+X(I))
  END DO
  XC(NI)=XMAX
!
  R    = X
  R    = 1.
END SUBROUTINE GRID

!#############################################################
SUBROUTINE CALCPRO
!#############################################################
  USE PARAM
  USE VAR
  IMPLICIT NONE

  CP  =  1.
  CON =  1
  DEN =  1.
END SUBROUTINE CALCPRO

!#############################################################
SUBROUTINE COEF1
!#############################################################
  USE PARAM
  USE VAR
  IMPLICIT NONE

  INTEGER I
  REAL(REAL_P) :: FAC,COND,APT,VOL,URF

  AP  =0.
!
!.....CALCULATE FLUXES THROUGH INNER CV-FACES:EAST
!
  DO I=2,NIM-1
FAC    = (X(I)-XC(I))/(XC(I+1)-XC(I))
COND = FAC*CON(I+1)+(1.-FAC)*CON(I)
AE(I) = -COND*R(I)/(XC(I+1)-XC(I))
AW(I+1) = AE(I)
  END DO
!
!.....TIME DISCRETIZATION -> EULER IMPLICIT
!
  DO I=2,NIM
VOL=0.5*(R(I)+R(I-1))*(X(I)-X(I-1))
APT=DEN(I)*CP(I)*VOL*DTR
AP(I)=AP(I)+APT
  END DO
!
!.....FINAL COEFFICIENT AND SOURCE MATRIX FOR FI-EQUATION
!
  DO I=1,NIM
AP(I)=AP(I)-AE(I)-AW(I)
  END DO
!
END SUBROUTINE COEF1

!#############################################################
SUBROUTINE COEF2(FIO)
!#############################################################
  USE PARAM
  USE VAR
  IMPLICIT NONE

  INTEGER I
  REAL(REAL_P)             :: APT,VOL
  REAL(REAL_P),DIMENSION(NMAX):: FIO

  SU  =0.
!
!.....TIME DISCRETIZATION -> EULER IMPLICIT
!
  DO I=2,NIM
VOL=0.5*(R(I)+R(I-1))*(X(I)-X(I-1))
APT=DEN(I)*CP(I)*VOL*DTR
SU(I)=SU(I)+APT*FIO(I)
  END DO
END SUBROUTINE COEF2
!
!#############################################################
SUBROUTINE BC(FI1,FIN)
!#############################################################
  USE PARAM
  USE VAR
  IMPLICIT NONE

  INTEGER I
  REAL(REAL_P) FI1,FIN
!
!.....BOUNDARY CONDITION FOR TEMP
!
  I = 2
  SU(I) = SU(I) + FI1*R(I-1)
  I = NIM
  SU(I) = SU(I) + FIN*R(I)
!
END SUBROUTINE BC
!
!#############################################################
SUBROUTINE BCPOST(FI,FI1,FIN)
!#############################################################
  USE PARAM
  USE VAR
  IMPLICIT NONE

  INTEGER I,IB
  REAL(REAL_P)                DN,FI1,FIN
  REAL(REAL_P),DIMENSION(NMAX)::FI

  I =2
  IB=I-1
  DN=XC(I)-XC(IB)
  FI(IB)=FI(I)+FI1*DN/CON(IB)

  I =NIM
  IB=I+1
  DN=XC(IB)-XC(I)
  FI(IB)=FI(I)+FIN*DN/CON(IB)
END SUBROUTINE BCPOST

!########################################################
PROGRAM ONEDINV
!########################################################
!    This program solves the unsteady one-dimensional
!    convection-diffusion equation with Dirichlet boundary
!    conditions on both ends. Initial solution is zero
!    field, boundary conditions are time-independent; the
!    transition from initial to steady solution is
!    simulated using different time integration schemes.
!
!    1995          M. Peric, Institut fuer Schiffbau
!########################################################
!
  USE PARAM
  USE VAR
  IMPLICIT NONE

  CHARACTER PNAME*20,FILIN*20,FILOUT*20
  INTEGER          :: IT,I,LS
  REAL(REAL_P)    :: S1,S2,DQ
!
!.....READ FILE NAMES AND OPEN FILES
!
  PRINT *,' ENTER PROBLEM NAME'
  READ(*,'(A5)') PNAME
  WRITE(FILIN, '(A5,4H.inp)') PNAME
  WRITE(FILOUT,'(A5,4H.dat)') PNAME
  OPEN (UNIT=1,FILE=FILIN)
  OPEN (UNIT=2,FILE=FILOUT)
  REWIND 1
  REWIND 2
!
!.....READ GRID DATA, CALCULATE NODE COORDINATES
!
  CALL GRID
!
!.....READ INIT TEMPERATURE AND MEASURED LOCATION
!
  PRINT *,' ENTER : TIME INTERVAL,TIME STEPS,NO. OF FUTURES,NO. OF INERS,NO. OF MEASURED LCOATION'
  READ(1,*) DT,NTMAX,NR,LMAX,NM
  PRINT *,' READ  : MEASURED LCOATIONS'
  READ(1,*) (IK(I),I=1,NM)
  PRINT *,' READ  : INIT TEMPERATURE'
!
  READ(1,*) (Y(1,I),I=1,NR)
  TIN = Y(1,1)
!
  CALL INIT
!
!.....START TIME LOOP (BETA = 0. FOR THE FIRST STEP & 3 LEVEL SCHEME)
!
  TIME=0.
  DTR=1./DT
!
  CALL TOUT(IT)

  DO IT=1,NTMAX
TIME=TIME+DT
!
DO I=1,NR-1
   Y(1,I) = Y(1,I+1)
END DO
IF(IT<NTMAX) READ(1,*) Y(1,NR)

!
!.....SHIFT SOLUTIONS TO OLDER LEVELS
!
TO = T
ZO = 0.
Q1 = 0.
!
!.....PHYP
!
CALL CALCPRO
CALL COEF1
CALL TDMA1

IF((NTMAX-IT+1)<NR) THEN
   NR =NTMAX-IT+1
END IF

DO LS=1,LMAX

   IF(LS==1) THEN
      S2 = 0.
Z =ZO
   END IF

   S1 = 0.
   T =TO
!
   DO I=1,NR
!
      TOO = T
CALL COEF2(TOO)
CALL BC(Q1,QN)
CALL TDMA2(T)
CALL BCPOST(T,Q1,QN)
!
IF(LS==1) THEN
   ZOO = Z
   CALL COEF2(ZOO)
   CALL BC(1._REAL_P,0._REAL_P)
   CALL TDMA2(Z)

   CALL BCPOST(Z,1._REAL_P,0._REAL_P)
   KK(I) = Z(IK(1))
   S2 = S2 + KK(I)*KK(I)
END IF
!
      S1 = S1 + (Y(1,I)-T(IK(1)))*KK(I)

   END DO

   DQ = S1/S2
   Q1 = Q1 + DQ

   ERR=ABS(DQ/Q1)

   WRITE(*,'(I10,I10,E10.3)') IT,LS,ERR

   IF(ERR<1.e-10) THEN
CALL COEF2(TO)
CALL BC(Q1,QN)
CALL TDMA2(T)
CALL BCPOST(T,Q1,QN)
CALL TOUT(IT)
      EXIT
   END IF
END DO
  END DO

  CLOSE(1)
  CLOSE(2)

END PROGRAM ONEDINV

SUBROUTINE INIT
  USE PARAM
  USE VAR
  IMPLICIT NONE
!
!.....INITIALIZE SOLUTION, SET BOUNDARY VALUES
!
  T  = TIN
  Z  = 0.
  QN =0.
!
END SUBROUTINE INIT
!
SUBROUTINE TOUT(IT)
  USE PARAM
  USE VAR
  IMPLICIT NONE
  INTEGER IT
!
!.....INITIALIZE SOLUTION, SET BOUNDARY VALUES
!
  WRITE(2,'(6E15.3)') TIME,T(1),Q1,T(NI),Y(1,1),Z(IK(1))
!
END SUBROUTINE TOUT

!#############################################################
SUBROUTINE TDMA1
!#############################################################
!  INITIAL VALUES OF VARIABLES BPR(I) AND V(I) ASSUMED ZERO!
!
USE PARAM
USE VAR
IMPLICIT NONE
INTEGER I
!
!.....CALCULATE 1./U_P (BPR)
!
BPR(1) = 0.
DO I=2,NIM
   BPR(I)=1./(AP(I)-AW(I)*AE(I-1)*BPR(I-1))
END DO
!
END SUBROUTINE TDMA1

!#############################################################
SUBROUTINE TDMA2(FI)
!#############################################################
USE PARAM
USE VAR
IMPLICIT NONE

REAL(REAL_P),DIMENSION(NMAX)::FI
INTEGER                   ::I
!
!.....CALCULATE MODIFIED SOURCE TERM (V)
!
V(1) = 0.
DO I=2,NIM
   V(I)=SU(I)-AW(I)*V(I-1)*BPR(I-1)
END DO
!
!.....CALCULATE VARIABLE VALUES - BACKWARD SUBSTITUTION
!
DO I=NIM,2,-1
   FI(I)=(V(I)-AE(I)*FI(I+1))*BPR(I)
END DO
RETURN
END SUBROUTINE TDMA2

回复此楼