TreeMig Code
Loading...
Searching...
No Matches
GFT_set.f90
Go to the documentation of this file.
1!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -*- Mode: F90 -*- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2!! GFT_set.f90 --- GFT initialization routines
3!!
4!! Auteur : Jalel Chergui (CNRS/IDRIS) <Jalel.Chergui@idris.fr>
5!! Cr�� le : Tue Feb 19 10:26:52 2002
6!! Dern. mod. par : Jalel Chergui (CNR S/IDRIS) <Jalel.Chergui@idris.fr>
7!! Dern. mod. le : Wed May 15 14:19:14 2002
8!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9!
10! Permission is granted to copy and distribute this file or modified
11! versions of this file for no fee, provided the copyright notice and
12! this permission notice are preserved on all copies.
13! Copyright February 2002, CNRS/IDRIS, Jalel.Chergui@idris.fr
14!
15MODULE gft_set
16 USE gft_common
17 USE gft_jmfft
18
19 IMPLICIT NONE
20
21 PRIVATE
22
23 PUBLIC :: gft_set_bf
24 INTERFACE gft_set_bf
25 MODULE PROCEDURE gft_set_bf_cc, gft_set_bf_rcr, gft_set_bf_mcc, &
26 gft_set_bf_mrcr
27 END INTERFACE gft_set_bf
28
29 PUBLIC :: gft_set_fft
30 INTERFACE gft_set_fft
31 MODULE PROCEDURE gft_set_cc_1d, gft_set_cc_2d, gft_set_cc_3d, &
32 gft_set_rcr_1d, gft_set_rcr_2d, gft_set_rcr_3d, &
33 gft_set_mcc, gft_set_mrcr
34 END INTERFACE gft_set_fft
35
36 CONTAINS
37
38 SUBROUTINE gft_set_bf_cc(BF, FFT, code)
39 IMPLICIT NONE
40
41 !... Input dummy arguments
42 INTEGER, INTENT(IN) :: BF
43
44 !... Output dummy arguments
45 TYPE(gft_cc), INTENT(OUT) :: FFT
46 INTEGER, OPTIONAL, INTENT(OUT) :: code
47
48 fft%BF=bf
49 IF( PRESENT(code) ) code=0
50 END SUBROUTINE gft_set_bf_cc
51
52 SUBROUTINE gft_set_bf_rcr(BF, FFT, code)
53 IMPLICIT NONE
54
55 !... Input dummy arguments
56 INTEGER, INTENT(IN) :: BF
57
58 !... Output dummy arguments
59 TYPE(gft_rcr), INTENT(OUT) :: FFT
60 INTEGER, OPTIONAL, INTENT(OUT) :: code
61
62
63
64 fft%BF=bf
65 IF( PRESENT(code) ) code=0
66 END SUBROUTINE gft_set_bf_rcr
67
68 SUBROUTINE gft_set_bf_mcc(BF, FFT, code)
69 IMPLICIT NONE
70
71 !... Input dummy arguments
72 INTEGER, INTENT(IN) :: BF
73
74 !... Output dummy arguments
75 TYPE(gft_mcc), INTENT(OUT) :: FFT
76 INTEGER, OPTIONAL, INTENT(OUT) :: code
77
78 fft%BF=bf
79 IF( PRESENT(code) ) code=0
80 END SUBROUTINE gft_set_bf_mcc
81
82 SUBROUTINE gft_set_bf_mrcr(BF, FFT, code)
83 IMPLICIT NONE
84
85 !... Input dummy arguments
86 INTEGER, INTENT(IN) :: BF
87
88 !... Output dummy arguments
89 TYPE(gft_mrcr), INTENT(OUT) :: FFT
90 INTEGER, OPTIONAL, INTENT(OUT) :: code
91
92 fft%BF=bf
93 IF( PRESENT(code) ) code=0
94 END SUBROUTINE gft_set_bf_mrcr
95
96 SUBROUTINE gft_set_cc_1d(Nx, FFT, code)
97 IMPLICIT NONE
98
99 !... Input dummy arguments
100 INTEGER, INTENT(IN) :: Nx
101
102 !... Output dummy arguments
103 TYPE(gft_cc), INTENT(OUT) :: FFT
104 INTEGER, OPTIONAL, INTENT(OUT) :: code
105
106 !... Local variables
107 INTEGER, DIMENSION(0:99) :: fact
108 INTEGER :: nfact
109 CHARACTER(LEN=*), PARAMETER :: spname="GFT_set_cc_1d"
110
111 CALL gft_copyright()
112
113 fft%Nx = nx
114 IF( fft%Nx < 1 ) CALL gft_error(spname//": Error: Nx < 1")
115
116 fft%Init = .true.
117 fft%TableSize = 100+2*fft%Nx
118 ALLOCATE(fft%Table(0:fft%TableSize-1))
119
120 fft%WorkSize = 4*fft%BF*fft%Nx
121 ALLOCATE(fft%Work(0:fft%WorkSize-1))
122
123 ! Pour la factorisation
124 CALL jmfact(fft%Nx,fact,100, 0,nfact)
125 fft%Table(0:nfact-1) = fact(0:nfact-1)
126
127 ! Pour les sinus et cosinus
128 CALL jmtable(fft%Table,fft%TableSize,100+0,fft%Nx)
129
130 IF( PRESENT(code) ) code=0
131 END SUBROUTINE gft_set_cc_1d
132
133 SUBROUTINE gft_set_cc_2d(Nx, Ny, FFT, code)
134 IMPLICIT NONE
135
136 !... Input dummy arguments
137 INTEGER, INTENT(IN) :: Nx, Ny
138
139 !... Output dummy arguments
140 TYPE(gft_cc), INTENT(OUT) :: FFT
141 INTEGER, OPTIONAL, INTENT(OUT) :: code
142
143 !... Internal variables
144 INTEGER, DIMENSION(0:99) :: fact
145 INTEGER :: nfact, mfact
146 CHARACTER(LEN=*), PARAMETER :: spname="GFT_set_cc_2d"
147
148 CALL gft_copyright()
149
150 fft%Nx = nx
151 fft%Ny = ny
152 IF( fft%Nx < 1 ) CALL gft_error(spname//": Error: NX < 1")
153 IF( fft%Ny < 1 ) CALL gft_error(spname//": Error: NY < 1")
154
155 fft%Init = .true.
156 fft%TableSize = 100+2*(fft%Nx + fft%Ny)
157 ALLOCATE(fft%Table(0:fft%TableSize-1))
158
159 fft%WorkSize = 4*fft%BF*max(fft%Nx, fft%Ny)
160 CALL jmsetnwork(fft%WorkSize)
161 ALLOCATE(fft%Work(0:fft%WorkSize-1))
162
163 !... Pour la factorisation
164 CALL jmfact(fft%Nx,fact,100, 0,nfact)
165 CALL jmfact(fft%Ny,fact,100,nfact,mfact)
166 fft%Table(0:mfact-1) = fact(0:mfact-1)
167
168 !... Pour les sinus et cosinus
169 CALL jmtable(fft%Table,fft%TableSize,100+0 ,fft%Nx)
170 CALL jmtable(fft%Table,fft%TableSize,100+2*fft%Nx,fft%Ny)
171
172 IF( PRESENT(code) ) code=0
173 END SUBROUTINE gft_set_cc_2d
174
175 SUBROUTINE gft_set_cc_3d(Nx, Ny, Nz, FFT, code)
176 IMPLICIT NONE
177
178 !... Input dummy arguments
179 INTEGER, INTENT(IN) :: Nx, Ny, Nz
180
181 !... Output dummy arguments
182 TYPE(gft_cc), INTENT(OUT) :: FFT
183 INTEGER, OPTIONAL, INTENT(OUT) :: code
184
185 !... Internal variables
186 INTEGER, DIMENSION(0:99) :: fact
187 INTEGER :: nfact, mfact, lfact
188 CHARACTER(LEN=*), PARAMETER :: spname="GFT_set_cc_3d"
189
190 CALL gft_copyright()
191
192 fft%Nx = nx
193 fft%Ny = ny
194 fft%Nz = nz
195 IF( fft%Nx < 1 ) CALL gft_error(spname//": Error: Nx < 1")
196 IF( fft%Ny < 1 ) CALL gft_error(spname//": Error: Ny < 1")
197 IF( fft%Nz < 1 ) CALL gft_error(spname//": Error: Nz < 1")
198
199 fft%Init = .true.
200 fft%TableSize = 100+2*(fft%Nx + fft%Ny + fft%Nz)
201 ALLOCATE(fft%Table(0:fft%TableSize-1))
202
203 fft%WorkSize = 4*fft%BF*max(fft%Nx, fft%Ny, fft%Nz)
204 CALL jmsetnwork(fft%WorkSize)
205 ALLOCATE(fft%Work(0:fft%WorkSize-1))
206
207 !... Pour la factorisation
208 CALL jmfact(fft%Nx,fact,100, 0,nfact)
209 CALL jmfact(fft%Ny,fact,100,nfact,mfact)
210 CALL jmfact(fft%Nz,fact,100,mfact,lfact)
211 fft%Table(0:lfact-1) = fact(0:lfact-1)
212
213 !... Pour les sinus et cosinus
214 CALL jmtable(fft%Table,fft%TableSize,100+0 , fft%Nx)
215 CALL jmtable(fft%Table,fft%TableSize,100+2*fft%Nx, fft%Ny)
216 CALL jmtable(fft%Table,fft%TableSize,100+2*(fft%Nx+fft%Ny),fft%Nz)
217
218 IF( PRESENT(code) ) code=0
219 END SUBROUTINE gft_set_cc_3d
220
221 SUBROUTINE gft_set_rcr_1d(Nx, FFT, code)
222 IMPLICIT NONE
223
224 !... Input dummy arguments
225 INTEGER, INTENT(IN) :: Nx
226
227 !... Output dummy arguments
228 TYPE(gft_rcr), INTENT(OUT) :: FFT
229 INTEGER, OPTIONAL, INTENT(OUT) :: code
230
231 !... Local variables
232 INTEGER, DIMENSION(0:99) :: fact
233 INTEGER :: nfact
234 CHARACTER(LEN=*), PARAMETER :: spname="GFT_set_rcr_1d"
235
236 CALL gft_copyright()
237
238 fft%Nx = nx
239 IF( fft%Nx < 1 ) CALL gft_error(spname//": Error: Nx < 1")
240 fft%even_x = (mod(fft%Nx,2) == 0 )
241 IF( .NOT.fft%even_x ) CALL gft_error(spname//": Error: Nx not even")
242
243 fft%Init = .true.
244 fft%TableSize = 100+2*fft%Nx
245 ALLOCATE(fft%Table(0:fft%TableSize-1))
246
247 fft%WorkSize = 2*fft%BF*fft%Nx
248 ALLOCATE(fft%Work(0:fft%WorkSize-1))
249
250 ! Pour la factorisation
251 CALL jmfact(fft%Nx,fact,100, 0,nfact)
252 fft%Table(0:nfact-1) = fact(0:nfact-1)
253
254 ! Pour les sinus et cosinus
255 CALL jmtable(fft%Table,fft%TableSize,100+0,fft%Nx)
256
257 IF( PRESENT(code) ) code=0
258 END SUBROUTINE gft_set_rcr_1d
259
260 SUBROUTINE gft_set_rcr_2d(Nx, Ny, FFT, code)
261 IMPLICIT NONE
262
263 !... Input dummy arguments
264 INTEGER, INTENT(IN) :: Nx, Ny
265
266 !... Output dummy arguments
267 TYPE(gft_rcr), INTENT(OUT) :: FFT
268 INTEGER, OPTIONAL, INTENT(OUT) :: code
269
270 !... Internal variables
271 INTEGER, DIMENSION(0:99) :: fact
272 INTEGER :: nfact, mfact
273 CHARACTER(LEN=*), PARAMETER :: spname="GFT_set_rcr_2d"
274!print *, spname
275 CALL gft_copyright()
276
277
278 fft%Nx = nx
279 fft%Ny = ny
280 IF( fft%Nx < 1 ) CALL gft_error(spname//": Error: Nx < 1")
281 IF( fft%Ny < 1 ) CALL gft_error(spname//": Error: Ny < 1")
282 fft%even_x = (mod(fft%Nx,2) == 0); fft%even_y = (mod(fft%Ny,2) == 0)
283 IF( .NOT.fft%even_x .AND. .NOT.fft%even_y) CALL gft_error(spname//": Error: Nx or Ny not even")
284
285 fft%Init = .true.
286 fft%TableSize = 100+2*(fft%Nx + fft%Ny)
287 ALLOCATE(fft%Table(0:fft%TableSize-1))
288
289 fft%WorkSize = 4*fft%BF*max(fft%Nx, fft%Ny)
290 CALL jmsetnwork(fft%WorkSize)
291 ALLOCATE(fft%Work(0:fft%WorkSize-1))
292
293 !... Pour la factorisation
294 CALL jmfact(fft%Nx,fact,100, 0,nfact)
295 CALL jmfact(fft%Ny,fact,100,nfact,mfact)
296 fft%Table(0:mfact-1) = fact(0:mfact-1)
297
298 !... Pour les sinus et cosinus
299 CALL jmtable(fft%Table,fft%TableSize,100+0 ,fft%Nx)
300 CALL jmtable(fft%Table,fft%TableSize,100+2*fft%Nx,fft%Ny)
301
302 IF( PRESENT(code) ) code=0
303 END SUBROUTINE gft_set_rcr_2d
304
305 SUBROUTINE gft_set_rcr_3d(Nx, Ny, Nz, FFT, code)
306 IMPLICIT NONE
307
308 !... Input dummy arguments
309 INTEGER, INTENT(IN) :: Nx, Ny, Nz
310
311 !... Output dummy arguments
312 TYPE(gft_rcr), INTENT(OUT) :: FFT
313 INTEGER, OPTIONAL, INTENT(OUT) :: code
314
315 !... Internal variables
316 INTEGER, DIMENSION(0:99) :: fact
317 INTEGER :: nfact, mfact, lfact
318 CHARACTER(LEN=*), PARAMETER :: spname="GFT_set_rcr_3d"
319
320 CALL gft_copyright()
321
322 fft%Nx = nx
323 fft%Ny = ny
324 fft%Nz = nz
325 IF( fft%Nx < 1 ) CALL gft_error(spname//": Error: Nx < 1")
326 IF( fft%Ny < 1 ) CALL gft_error(spname//": Error: Ny < 1")
327 IF( fft%Nz < 1 ) CALL gft_error(spname//": Error: Nz < 1")
328 fft%even_x = (mod(fft%Nx,2) == 0)
329 fft%even_y = (mod(fft%Ny,2) == 0)
330 fft%even_z = (mod(fft%Nz,2) == 0)
331 IF( .NOT.fft%even_x .AND. .NOT.fft%even_y .AND. .NOT.fft%even_z) &
332 CALL gft_error(spname//": Error: Nx or Ny or Nz not even")
333
334 fft%Init = .true.
335 fft%TableSize = 100+2*(fft%Nx + fft%Ny + fft%Nz)
336 ALLOCATE(fft%Table(0:fft%TableSize-1))
337
338 fft%WorkSize = 4*fft%BF*max(fft%Nx, fft%Ny, fft%Nz)
339 CALL jmsetnwork(fft%WorkSize)
340 ALLOCATE(fft%Work(0:fft%WorkSize-1))
341
342 !... Pour la factorisation
343 CALL jmfact(fft%Nx,fact,100, 0,nfact)
344 CALL jmfact(fft%Ny,fact,100,nfact,mfact)
345 CALL jmfact(fft%Nz,fact,100,mfact,lfact)
346 fft%Table(0:lfact-1) = fact(0:lfact-1)
347
348 !... Pour les sinus et cosinus
349 CALL jmtable(fft%Table,fft%TableSize,100+0 ,fft%Nx)
350 CALL jmtable(fft%Table,fft%TableSize,100+2*fft%Nx ,fft%Ny)
351 CALL jmtable(fft%Table,fft%TableSize,100+2*(fft%Nx+fft%Ny),fft%Nz)
352
353 IF( PRESENT(code) ) code=0
354 END SUBROUTINE gft_set_rcr_3d
355
356 SUBROUTINE gft_set_mcc(Nx, Ny, FFT, code)
357 IMPLICIT NONE
358
359 !... Input dummy arguments
360 INTEGER, INTENT(IN) :: Nx, Ny
361
362 !... Output dummy arguments
363 TYPE(gft_mcc), INTENT(OUT) :: FFT
364 INTEGER, OPTIONAL, INTENT(OUT) :: code
365
366 !... Internal variables
367 INTEGER, DIMENSION(0:99) :: fact
368 INTEGER :: nfact
369 CHARACTER(LEN=*), PARAMETER :: spname="GFT_set_mcc"
370
371 CALL gft_copyright()
372
373 fft%Nx = nx
374 fft%Ny = ny
375 IF( fft%Nx < 1 ) CALL gft_error(spname//": Error: Nx < 1")
376 IF( fft%Ny < 1 ) CALL gft_error(spname//": Error: Ny < 1")
377
378 fft%Init = .true.
379 fft%TableSize = 100+2*fft%Nx
380 ALLOCATE(fft%Table(0:fft%TableSize-1))
381
382 fft%WorkSize = 4*fft%BF*fft%Nx*fft%Ny
383 ALLOCATE(fft%Work(0:fft%WorkSize-1))
384
385 !... Pour la factorisation
386 CALL jmfact(fft%Nx,fact,100,0,nfact)
387 fft%Table(0:nfact-1) = fact(0:nfact-1)
388
389 !... Pour les sinus et cosinus
390 CALL jmtable(fft%Table,fft%TableSize,100+0,fft%Nx)
391
392 IF( PRESENT(code) ) code=0
393 END SUBROUTINE gft_set_mcc
394
395 SUBROUTINE gft_set_mrcr(Nx, Ny, FFT, code)
396 IMPLICIT NONE
397
398 !... Input dummy arguments
399 INTEGER, INTENT(IN) :: Nx, Ny
400
401 !... Output dummy arguments
402 TYPE(gft_mrcr), INTENT(OUT) :: FFT
403 INTEGER, OPTIONAL, INTENT(OUT) :: code
404
405 !... Internal variables
406 INTEGER, DIMENSION(0:99) :: fact
407 INTEGER :: nfact
408 CHARACTER(LEN=*), PARAMETER :: spname="GFT_set_mrcr"
409
410 CALL gft_copyright()
411
412 fft%Nx = nx
413 fft%Ny = ny
414 !... Check conditions
415 IF( fft%Nx < 1 ) CALL gft_error(spname//": Error: Nx < 1")
416 IF( fft%Ny < 1 ) CALL gft_error(spname//": Error: Ny < 1")
417 fft%even_x = (mod(fft%Nx,2) == 0) ; fft%even_y = (mod(fft%Ny,2) == 0)
418 IF( .NOT.fft%even_x .AND. .NOT.fft%even_y ) CALL gft_error(spname//": Error: Nx or Ny not even")
419
420 fft%Init = .true.
421 fft%TableSize = 100+2*fft%Nx
422 ALLOCATE(fft%Table(0:fft%TableSize-1))
423
424 fft%WorkSize = 2*fft%BF*fft%Nx*fft%Ny
425 ALLOCATE(fft%Work(0:fft%WorkSize-1))
426
427 ! Pour la factorisation
428 CALL jmfact(fft%Nx,fact,100, 0,nfact)
429 fft%Table(0:nfact-1) = fact(0:nfact-1)
430
431 ! Pour les sinus et cosinus
432 CALL jmtable(fft%Table,fft%TableSize,100+0,fft%Nx)
433
434 IF( PRESENT(code) ) code=0
435 END SUBROUTINE gft_set_mrcr
436
437END MODULE gft_set
gft_set::gft_set_bf
Definition GFT_set.f90:24
gft_set::gft_set_fft
Definition GFT_set.f90:30
gft_common
Definition GFT_common.f90:15
gft_common::gft_copyright
subroutine gft_copyright
Definition GFT_common.f90:127
gft_common::gft_error
subroutine gft_error(message)
Definition GFT_common.f90:108
gft_jmfft
Definition GFT_jmfft.f90:15
gft_jmfft::jmtable
subroutine jmtable(table, ntable, itable, n)
Definition GFT_jmfft.f90:21
gft_jmfft::jmfact
subroutine jmfact(n, fact, nfact, ideb, ifin)
Definition GFT_jmfft.f90:107
gft_jmfft::jmsetnwork
subroutine jmsetnwork(nwork)
Definition GFT_jmfft.f90:2129
gft_set
Definition GFT_set.f90:15
gft_common::gft_cc
Definition GFT_common.f90:30
gft_common::gft_mcc
Definition GFT_common.f90:72
gft_common::gft_mrcr
Definition GFT_common.f90:88
gft_common::gft_rcr
Definition GFT_common.f90:49