Alexander_KS/SAPFOR
4
2
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

finalyze moving

Browse Source
This commit is contained in:
Alexander
2025-03-12 14:28:04 +03:00
committed by Dudarenko
parent de4690513b
commit 189374274e
776 changed files with 0 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1513
tests/sapfor/parameter/magnit_3d.for Normal file
View File

File diff suppressed because it is too large Load Diff

610
tests/sapfor/parameter/mycom.for Normal file
View File

@@ -0,0 +1,610 @@
! ----------------------------------------------------------------------
! My common library. Modified 03/09/2017.
! ----------------------------------------------------------------------
! Modified DEGREE function:
! ----------------------------------------------------------------------
FUNCTION DEGREE (A, B)
!
IMPLICIT REAL*8 (A-H,O-Z)
IMPLICIT INTEGER*4 (I-N)
!
IF (A .GE. 1D-15) THEN
DEGREE = A** B
ELSE
DEGREE = 0D0
ENDIF
!
RETURN
END
! ----------------------------------------------------------------------
! Modified SQRT function:
! ----------------------------------------------------------------------
FUNCTION DSQRTM (A)
!
IMPLICIT REAL*8 (A-H,O-Z)
IMPLICIT INTEGER*4 (I-N)
!
IF (A .GE. 1D-15) THEN
DSQRTM = DSQRT (A)
ELSE
DSQRTM = 0D0
ENDIF
!
RETURN
END
! ----------------------------------------------------------------------
! Modified exponent function:
! ----------------------------------------------------------------------
FUNCTION DEXPM (X)
!
IMPLICIT REAL*8 (A-H,O-Z)
IMPLICIT INTEGER*4 (I-N)
!
IF (X .LE. (-(308D0))) THEN
DEXPM = 0D0
ELSE
DEXPM = DEXP (X)
ENDIF
!
RETURN
END
! ----------------------------------------------------------------------
! Modified sin:
! ----------------------------------------------------------------------
REAL*8 FUNCTION DSINM (X)
!
IMPLICIT INTEGER*4 (I-N)
IMPLICIT REAL*8 (A-H,O-Z)
!
Y = DSIN (X)
!
IF (DABS (Y) .GT. 1D-15) THEN
DSINM = Y
ELSE
DSINM = 0D0
ENDIF
!
RETURN
END
! ----------------------------------------------------------------------
! Modified cosin:
! ----------------------------------------------------------------------
REAL*8 FUNCTION DCOSM (X)
!
IMPLICIT INTEGER*4 (I-N)
IMPLICIT REAL*8 (A-H,O-Z)
!
Y = DCOS (X)
!
IF (DABS (Y) .GT. 1D-15) THEN
DCOSM = Y
ELSE
DCOSM = 0D0
ENDIF
!
RETURN
END
! ----------------------------------------------------------------------
! Output function DZERO:
! ----------------------------------------------------------------------
FUNCTION DZERO (A)
!
IMPLICIT REAL*8 (A-H,O-Z)
IMPLICIT INTEGER*4 (I-N)
!
B = DABS (A)
!
IF (B .GE. 1D-99) THEN
DZERO = A
ELSE
DZERO = 0D0
ENDIF
!
RETURN
END
! ----------------------------------------------------------------------
! Output function DZERO2:
! ----------------------------------------------------------------------
FUNCTION DZERO2 (A, EPS)
!
IMPLICIT REAL*8 (A-H,O-Z)
IMPLICIT INTEGER*4 (I-N)
!
B = DABS (A)
!
IF (B .GE. EPS) THEN
DZERO2 = A
ELSE
DZERO2 = 0D0
ENDIF
!
RETURN
END
! ----------------------------------------------------------------------
! Angle of point (x,y), angle in [0,2pi)
! ----------------------------------------------------------------------
FUNCTION DANGLE (X, Y)
IMPLICIT INTEGER*4 (I-N)
IMPLICIT REAL*8 (A-H,O-Z)
!
C_PI = 4D0 * DATAN (1D0)
!
IF (X .EQ. 0D0) THEN
IF (Y .EQ. 0D0) THEN
!- x = 0, y = 0
A = 0D0
ELSE IF (Y .GT. 0D0) THEN
!- x = 0, y > 0
A = .5D0 * C_PI
ELSE
!- x = 0, y < 0
A = 1.5D0 * C_PI
ENDIF
ELSE IF (Y .EQ. 0D0) THEN
IF (X .GT. 0D0) THEN
!- x > 0, y = 0
A = 0D0
ELSE
!- x < 0, y = 0
A = C_PI
ENDIF
!- x <> 0, y <> 0
ELSE
AX = DABS (X)
AY = DABS (Y)
!- |x| = |y|
IF (AX .EQ. AY) THEN
IF (X .GT. 0D0) THEN
IF (Y .GT. 0D0) THEN
!- x > 0, y > 0
A = 0.25D0 * C_PI
ELSE
!- x > 0, y < 0
A = 1.75D0 * C_PI
ENDIF
ELSE
IF (Y .GT. 0D0) THEN
!- x < 0, y > 0
A = 0.75D0 * C_PI
ELSE
!- x < 0, y < 0
A = 1.25D0 * C_PI
ENDIF
ENDIF
ELSE
IF (AX .GT. AY) THEN
!- |x| > |y|
A = DATAN (AY / AX)
ELSE
!- |x| < |y|
A = .5D0 * C_PI - DATAN (AX / AY)
ENDIF
IF (X .LT. 0D0) THEN
IF (Y .LT. 0D0) THEN
!- x < 0, y < 0
A = C_PI + A
ELSE
!- x < 0, y > 0
A = C_PI - A
ENDIF
ELSE
IF (Y .LT. 0D0) THEN
!- x > 0, y < 0
A = 2D0 * C_PI - A
ENDIF
ENDIF
ENDIF
ENDIF
!
DANGLE = A
!
RETURN
END
! ----------------------------------------------------------------------
! My Entier:
! ----------------------------------------------------------------------
INTEGER*4 FUNCTION MYROUND (X)
!
IMPLICIT INTEGER*4 (I-N)
IMPLICIT REAL*8 (A-H,O-Z)
!
I = IDINT (X)
Z = X - 1D0 * I
!
IF (Z .LE. 0.5D0) THEN
MYROUND = I
ELSE
MYROUND = I + 1
ENDIF
!
RETURN
END
! ----------------------------------------------------------------------
! f(x) is set by three points: (x1,f1), (x2,f2), (x3,f3)
!
! P2(x) = f2 + c1*(x-x2) + c2*(x-x2)*(x-x2) - approximation
! ----------------------------------------------------------------------
FUNCTION FP2 (X1, X2, X3, F1, F2, F3, X)
!
IMPLICIT INTEGER*4 (I-N)
IMPLICIT REAL*8 (A-H,O-Z)
!
DX12 = X1 - X2
DX32 = X3 - X2
!
DFDX12 = (F1 - F2) / DX12
DFDX32 = (F3 - F2) / DX32
!
C2 = (DFDX32 - DFDX12) / (DX32 - DX12)
C1 = DFDX12 - C2 * DX12
!
FP2 = F2 + C1 * (X - X2) + C2 * (X - X2) * (X - X2)
!
RETURN
END
! ----------------------------------------------------------------------
! P2'(x) = c1 + 2*c2*(x-x2)
! ----------------------------------------------------------------------
FUNCTION FP2P1 (X1, X2, X3, F1, F2, F3, X)
!
IMPLICIT INTEGER*4 (I-N)
IMPLICIT REAL*8 (A-H,O-Z)
!
DX12 = X1 - X2
DX32 = X3 - X2
!
DFDX12 = (F1 - F2) / DX12
DFDX32 = (F3 - F2) / DX32
!
C2 = (DFDX32 - DFDX12) / (DX32 - DX12)
C1 = DFDX12 - C2 * DX12
!
FP2P1 = C1 + 2D0 * C2 * (X - X2)
!
RETURN
END
! ----------------------------------------------------------------------
! In integer range:
! ----------------------------------------------------------------------
INTEGER*4 FUNCTION IN_RANGE_I (I1, I2, I)
!
IMPLICIT INTEGER*4 (I-N)
IMPLICIT REAL*8 (A-H,O-Z)
!
IF (I1 .LE. I .AND. I .LE. I2) THEN
IN_RANGE_I = 0
ELSE
IN_RANGE_I = 1
ENDIF
!
RETURN
END
! ----------------------------------------------------------------------
! In real range:
! ----------------------------------------------------------------------
INTEGER*4 FUNCTION IN_RANGE_D (A, B, X)
!
IMPLICIT INTEGER*4 (I-N)
IMPLICIT REAL*8 (A-H,O-Z)
!
IF (A .LE. X .AND. X .LE. B) THEN
IN_RANGE_D = 0
ELSE
IF (X .LT. A) THEN
IN_RANGE_D = 1
ELSE
IN_RANGE_D = 2
ENDIF
ENDIF
!
RETURN
END
! ----------------------------------------------------------------------
! Compare of edges & faces:
! ----------------------------------------------------------------------
FUNCTION ICMP2 (I1, I2, I3, I4)
IMPLICIT INTEGER*4 (I-N)
IMPLICIT REAL*8 (A-H,O-Z)
!
IF (I1 .LE. I2) THEN
K1 = I1
K2 = I2
ELSE
K1 = I2
K2 = I1
ENDIF
!
IF (I3 .LE. I4) THEN
K3 = I3
K4 = I4
ELSE
K3 = I4
K4 = I3
ENDIF
!
IF (K1 .EQ. K3 .AND. K2 .EQ. K4) THEN
ICMP2 = 1
ELSE
ICMP2 = 0
ENDIF
!
RETURN
END
! ----------------------------------------------------------------------
! Section procedure:
! ----------------------------------------------------------------------
SUBROUTINE SECT1D (NP, MP, IB, IE, I1, I2)
!
IMPLICIT REAL*8 (A-H,O-Z)
IMPLICIT INTEGER*4 (I-N)
!
IF (NP .EQ. 1) THEN
I1 = IB
I2 = IE
ELSE
NC = IE - IB + 1
NI = NC / NP
MI = NC - NI * NP
!
IF (MP + 1 .LE. MI) THEN
I1 = IB + MP * (NI + 1)
I2 = I1 + NI
ELSE
I1 = IB + MI * (NI + 1) + (MP - MI) * NI
I2 = I1 + NI - 1
ENDIF
ENDIF
!
RETURN
END
! ----------------------------------------------------------------------
! Length of string.
! ----------------------------------------------------------------------
INTEGER FUNCTION LENSTR (S)
CHARACTER*(*) :: S
L = LEN (S)
1 IF (S(L:L) .EQ. ' ') THEN
L = L - 1
IF (L .GT. 0) GOTO 1
ENDIF
LENSTR = L
RETURN
END
! ----------------------------------------------------------------------
! Read string:
! ----------------------------------------------------------------------
SUBROUTINE READSTR (ICH, STR, IER)
!
CHARACTER*(*) :: STR
!
IER = (-(1))
!
N = MIN0 (1024,LEN (STR))
!
IF (N .LT. 1) GOTO 10
!
IER = (-(2))
!
DO I = 1,N
STR(I:I) = ' '
ENDDO
!
K = 0
!
DO WHILE (.NOT.(EOF (ICH)) .AND. K .EQ. 0)
READ (UNIT = ICH,FMT = '(1024(a1))',END = 5,ERR = 10) (STR(I:I)
&, I = 1,1024)
5 IF (STR(1:1) .NE. '#') K = 1
ENDDO
!
IER = 0
!
10 RETURN
END
! ----------------------------------------------------------------------
! Tecplot 2D, integer*4
! ----------------------------------------------------------------------
SUBROUTINE TPL2D_REC_I (ICH, FNAME, TNAME, VNAME, N1, N2, X1, X2,
&X3)
!
IMPLICIT INTEGER*4 (I-N)
IMPLICIT REAL*8 (A-H,O-Z)
!
CHARACTER*(*) :: FNAME,TNAME,VNAME
!
REAL*8 :: X1(N1),X2(N2)
INTEGER*4 :: X3(N1,N2)
!
OPEN (UNIT = ICH,FILE = FNAME)
!
WRITE (UNIT = ICH,FMT = *) TNAME
WRITE (UNIT = ICH,FMT = *) VNAME
WRITE (UNIT = ICH,FMT = *) 'ZONE T="BIG" I=',N1,' J=',N2,' F=POINT
&'
!
DO J = 1,N2
V2 = X2(J)
DO I = 1,N1
V1 = X1(I)
V3 = 1D0 * X3(I,J)
WRITE (UNIT = ICH,FMT = '(3(1x,1pe15.8))') V1,V2,V3
ENDDO
ENDDO
!
CLOSE (UNIT = ICH)
!
RETURN
END
! ----------------------------------------------------------------------
! Tecplot 2D, real*8
! ----------------------------------------------------------------------
SUBROUTINE TPL2D_REC_D (ICH, FNAME, TNAME, VNAME, N1, N2, X1, X2,
&X3)
!
IMPLICIT INTEGER*4 (I-N)
IMPLICIT REAL*8 (A-H,O-Z)
!
CHARACTER*(*) :: FNAME,TNAME,VNAME
!
REAL*8 :: X1(N1),X2(N2)
REAL*8 :: X3(N1,N2)
!
OPEN (UNIT = ICH,FILE = FNAME)
!
WRITE (UNIT = ICH,FMT = *) TNAME
WRITE (UNIT = ICH,FMT = *) VNAME
WRITE (UNIT = ICH,FMT = *) 'ZONE T="BIG" I=',N1,' J=',N2,' F=POINT
&'
!
DO J = 1,N2
V2 = X2(J)
DO I = 1,N1
V1 = X1(I)
V3 = X3(I,J)
WRITE (UNIT = ICH,FMT = '(3(1x,1pe15.8))') V1,V2,V3
ENDDO
ENDDO
!
CLOSE (UNIT = ICH)
!
RETURN
END

50
tests/sapfor/parameter/parameter.f90 Normal file
View File

@@ -0,0 +1,50 @@
program PARAMTER
call check
end
module constants
implicit none
real, parameter::pi = 3.1415926536
real, parameter::e = 2.7182818285
contains
subroutine show_consts()
print*, "Pi = ", pi
contains
subroutine show_e()
print*, "e = ", e
end subroutine show_e
end subroutine show_consts
end module constants
subroutine check
implicit none
use constants!, only: pi, p=>pi
common /global/ key
real key
integer n,m,k,l,pn,nl,i,j,ii,jj,nnl
parameter(N=6,M=8,K=8,L=6,PN=2,NL=1000)
integer A(N,M,K,L)
character*9 tname
tname='check'
NNL=NL
!$SPF ANALYSIS(PARAMETER(N=N))
!$SPF ANALYSIS(PARAMETER(N=6))
!$SPF ANALYSIS(PARAMETER(N=6,M=8))
!$SPF ANALYSIS(PARAMETER(N=M-2))
!$SPF ANALYSIS(PARAMETER(A(i,j,ii,jj)=M-2, i=1))
do i=1,N
!$SPF ANALYSIS(PARAMETER(M=8))
do j=1,M
do ii=1,K
do jj=1,L
!$SPF ANALYSIS(PARAMETER(NL=9*111+1))
!$SPF ANALYSIS(PARAMETER(A(i,j,ii,jj)=M-2, i=1))
!$SPF ANALYSIS(PARAMETER(A=(M-2)*key))
A(i,j,ii,jj) = NL+i+j+ii+jj
enddo
enddo
enddo
enddo
end