1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
|
!
!---------------------------------------------------------------------
!
!Purpose:
! Support module for numerical functions.
!
!Copyright:
! Copyright (C) 2001 Ecole Polytechnique de Montreal.
!
!Author(s):
! X. Warin
!
!---------------------------------------------------------------------
!
MODULE SAL_NUMERIC_MOD
USE PRECISION_AND_KINDS, ONLY : PDB
CONTAINS
!
FUNCTION SALACO(COSANG,Y)
!
!---------------------------------------------------------------------
!
!Purpose:
! computes angle in radians for given cosinus and y component
!
!Parameters: input
! COSANG cosinus of angle
! Y component (to give sign)
!
!Parameters: output
! SALACO angle in radiants
!
!---------------------------------------------------------------------
!
USE PRECISION_AND_KINDS, ONLY : PDB,PI,TWOPI
!**
REAL(PDB) :: SALACO
REAL(PDB),INTENT(IN) :: COSANG,Y
!*****
IF(ABS(COSANG).LT.1.0_PDB) THEN
SALACO=ACOS(COSANG)
ELSEIF(COSANG.GE.1.0_PDB) THEN
SALACO=0.0_PDB
ELSE
SALACO=PI
ENDIF
IF(Y.LT.0.0_PDB) SALACO=TWOPI-SALACO
!
END FUNCTION SALACO
!
SUBROUTINE SAL141(TYPE,RPAR,X,Y,IEND)
!
!---------------------------------------------------------------------
!
!Purpose:
! computes coordinates of end of an element
!
!Parameters: input
! TYPE type of element 1 (segment) 3 (arc of circle)
! RPAR floating-point descriptors of the element
! IEND = 1 (end is origin of element)
! 2 (end is end of the element)
!
!Parameters: output
! X abscissa coordinates of end
! Y ordinate coordinates of end
!
!---------------------------------------------------------------------
!
IMPLICIT NONE
INTEGER, INTENT(IN) :: TYPE,IEND
REAL(PDB), INTENT(OUT) :: X,Y
REAL(PDB), INTENT(IN), DIMENSION(:) :: RPAR
! DIMENSION RPAR(*)
!****
REAL(PDB) :: THETA,R
!****
X=RPAR(1)
Y=RPAR(2)
IF(TYPE.EQ.1)THEN
! segment
IF(IEND.EQ.2)THEN
X=X+RPAR(3)
Y=Y+RPAR(4)
ENDIF
ELSEIF(TYPE.LE.3)THEN
! arc of circle
IF(IEND.EQ.1)THEN
THETA=RPAR(4)
ELSE
THETA=RPAR(5)
ENDIF
R=RPAR(3)
X=X+R*COS(THETA)
Y=Y+R*SIN(THETA)
ELSE
CALL XABORT('SAL141: not implemented')
ENDIF
!
END SUBROUTINE SAL141
!
RECURSIVE FUNCTION DET_ROSETTA(MAT, N) RESULT(ACCUM)
!
!---------------------------------------------------------------------
!
!Purpose:
! compute the determinant of matrix MAT(N, N)
!
!---------------------------------------------------------------------
!
INTEGER, INTENT(IN) :: N
REAL(PDB), INTENT(IN) :: MAT(N, N)
REAL(PDB) :: SUBMAT(N-1, N-1), ACCUM
INTEGER :: I, SGN
IF(N == 1) THEN
ACCUM = MAT(1,1)
ELSE
ACCUM = 0.0
SGN = 1
DO I = 1, N
SUBMAT(1:N-1, 1:I-1) = MAT(2:N, 1:I-1)
SUBMAT(1:N-1, I:N-1) = MAT(2:N, I+1:N)
ACCUM = ACCUM + SGN * MAT(1, I) * DET_ROSETTA(SUBMAT, N-1)
SGN = - SGN
ENDDO
ENDIF
END FUNCTION DET_ROSETTA
!
FUNCTION FINDLC(ISET,ITEST) RESULT(II)
!
!---------------------------------------------------------------------
!
!Purpose:
! function emulating the findloc function in fortran 2008
!
!---------------------------------------------------------------------
!
INTEGER, DIMENSION(:), INTENT(IN) :: ISET
INTEGER, INTENT(IN) :: ITEST
INTEGER :: II
II=0
DO J=1,SIZE(ISET)
IF(ISET(J) == ITEST) THEN
II=J
EXIT
ENDIF
ENDDO
END FUNCTION FINDLC
END MODULE SAL_NUMERIC_MOD
|
