source: palm/trunk/SOURCE/random_generator_parallel_mod.f90 @ 2053

Last change on this file since 2053 was 2001, checked in by knoop, 8 years ago

last commit documented

  • Property svn:keywords set to Id
File size: 16.3 KB
RevLine 
[1850]1!> @file random_generator_parallel_mod.f90
[1400]2!------------------------------------------------------------------------------!
3! This file is part of PALM.
4!
[2000]5! PALM is free software: you can redistribute it and/or modify it under the
6! terms of the GNU General Public License as published by the Free Software
7! Foundation, either version 3 of the License, or (at your option) any later
8! version.
[1400]9!
10! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
11! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
13!
14! You should have received a copy of the GNU General Public License along with
15! PALM. If not, see <http://www.gnu.org/licenses/>.
16!
[1818]17! Copyright 1997-2016 Leibniz Universitaet Hannover
[1400]18!------------------------------------------------------------------------------!
19!
20! Current revisions:
21! -----------------
22!
[2001]23!
[1400]24! Former revisions:
25! -----------------
26! $Id: random_generator_parallel_mod.f90 2001 2016-08-20 18:41:22Z gronemeier $
27!
[2001]28! 2000 2016-08-20 18:09:15Z knoop
29! Forced header and separation lines into 80 columns
30!
[1851]31! 1850 2016-04-08 13:29:27Z maronga
32! Module renamed
33!
34!
[1683]35! 1682 2015-10-07 23:56:08Z knoop
36! Code annotations made doxygen readable
37!
[1401]38! 1400 2014-05-09 14:03:54Z knoop
39! Initial revision
40!
[1400]41!
42! Description:
43! ------------
[1682]44!> This module contains and supports the random number generating routine ran_parallel.
45!> ran_parallel returns a uniform random deviate between 0.0 and 1.0
46!> (exclusive of the end point values).
47!> Additionally it provides the generator with five integer for use as initial state space.
48!> The first tree integers (iran, jran, kran) are maintained as non negative values,
49!> while the last two (mran, nran) have 32-bit nonzero values.
50!> Also provided by this module is support for initializing or reinitializing
51!> the state space to a desired standard sequence number, hashing the initial
52!> values to random values, and allocating and deallocating the internal workspace
53!> Random number generator, produces numbers equally distributed in interval
54!>
55!> This routine is taken from the "numerical recipies vol. 2"
[1400]56!------------------------------------------------------------------------------!
[1682]57MODULE random_generator_parallel
58 
[1400]59
60   USE kinds
61   
62   IMPLICIT NONE
63   
64   PRIVATE
65   PUBLIC random_number_parallel, random_seed_parallel, random_dummy,          &
66          id_random_array, seq_random_array
67   
[1682]68   INTEGER(isp), SAVE :: lenran=0             !<
69   INTEGER(isp), SAVE :: seq=0                !<
70   INTEGER(isp), SAVE :: iran0                !<
71   INTEGER(isp), SAVE :: jran0                !<
72   INTEGER(isp), SAVE :: kran0                !<
73   INTEGER(isp), SAVE :: mran0                !<
74   INTEGER(isp), SAVE :: nran0                !<
75   INTEGER(isp), SAVE :: rans                 !<
[1400]76   
[1682]77   INTEGER(isp), DIMENSION(:, :), POINTER, SAVE :: ranseeds   !<
[1400]78   
[1682]79   INTEGER(isp), DIMENSION(:), POINTER, SAVE :: iran   !<
80   INTEGER(isp), DIMENSION(:), POINTER, SAVE :: jran   !<
81   INTEGER(isp), DIMENSION(:), POINTER, SAVE :: kran   !<
82   INTEGER(isp), DIMENSION(:), POINTER, SAVE :: mran   !<
83   INTEGER(isp), DIMENSION(:), POINTER, SAVE :: nran   !<
84   INTEGER(isp), DIMENSION(:), POINTER, SAVE :: ranv   !<
[1400]85   
86   
87   
[1682]88   INTEGER(isp), DIMENSION(:,:), ALLOCATABLE   ::  id_random_array    !<
89   INTEGER(isp), DIMENSION(:,:,:), ALLOCATABLE ::  seq_random_array   !<
[1400]90   
[1682]91   REAL(wp), SAVE :: amm   !<
[1400]92   
[1682]93   REAL(wp) :: random_dummy=0.0   !<
[1400]94   
95   INTERFACE random_number_parallel
96      MODULE PROCEDURE ran0_s
97   END INTERFACE
98   
99   INTERFACE random_seed_parallel
100      MODULE PROCEDURE random_seed_parallel
101   END INTERFACE
102   
103   INTERFACE ran_hash
104      MODULE PROCEDURE ran_hash_v
105   END INTERFACE
106   
107   INTERFACE reallocate
108      MODULE PROCEDURE reallocate_iv,reallocate_im
109   END INTERFACE
110   
111   INTERFACE arth
112      MODULE PROCEDURE arth_i
113   END INTERFACE
114
115 CONTAINS
116 
117!------------------------------------------------------------------------------!
118! Description:
119! ------------
[1682]120!> Lagged Fibonacci generator combined with a Marsaglia shiftsequence.
121!> Returns as harvest a uniform random deviate between 0.0 and 1.0 (exclusive of the end point values).
122!> This generator has the same calling and initialization conventions as Fortran 90's random_number routine.
123!> Use random_seed_parallel to initialize or reinitialize to a particular sequence.
124!> The period of this generator is about 2.0 x 10^28, and it fully vectorizes.
125!> Validity of the integer model assumed by this generator is tested at initialization.
[1400]126!------------------------------------------------------------------------------!
127   SUBROUTINE ran0_s(harvest)
128
129      USE kinds
130     
131      IMPLICIT NONE
132     
[1682]133      REAL(wp), INTENT(OUT) :: harvest   !<
[1400]134     
135      IF  (lenran < 1) CALL ran_init(1)  !- Initialization routine in ran_state.
136     
137      !- Update Fibonacci generator, which has period p^2 + p + 1, p = 2^31 - 69.
138      rans = iran0 - kran0   
139     
140      IF  (rans < 0) rans = rans + 2147483579_isp
141     
142      iran0 = jran0
143      jran0 = kran0
144      kran0 = rans
145     
146      nran0 = ieor( nran0, ishft (nran0, 13) ) !- Update Marsaglia shift sequence with period 2^32 - 1.
147      nran0 = ieor( nran0, ishft (nran0, -17) )
148      nran0 = ieor( nran0, ishft (nran0, 5) )
149     
150      rans  = ieor( nran0, rans )   !- Combine the generators.
151     
152      harvest = amm * merge( rans, not(rans), rans < 0 ) !- Make the result positive definite (note that amm is negative).
153     
154   END SUBROUTINE ran0_s
155
156!------------------------------------------------------------------------------!
157! Description:
158! ------------
[1682]159!> Initialize or reinitialize the random generator state space to vectors of size length.
160!> The saved variable seq is hashed (via calls to the module routine ran_hash)
161!> to create unique starting seeds, different for each vector component.
[1400]162!------------------------------------------------------------------------------!
163   SUBROUTINE ran_init( length )
164   
165      USE kinds
166     
167      IMPLICIT NONE
168     
[1682]169      INTEGER(isp), INTENT(IN) ::  length   !<
[1400]170   
[1682]171      INTEGER(isp), PARAMETER:: hg=huge(1_isp)   !<
172      INTEGER(isp), PARAMETER:: hgm=-hg          !<
173      INTEGER(isp), PARAMETER:: hgng=hgm-1       !<
[1400]174     
[1682]175      INTEGER(isp) ::  new   !<
176      INTEGER(isp) ::  j     !<
177      INTEGER(isp) ::  hgt   !<
[1400]178     
179      IF ( length < lenran ) RETURN !- Simply return if enough space is already allocated.
180     
181      hgt = hg
182     
183      !- The following lines check that kind value isp is in fact a 32-bit integer
184      !- with the usual properties that we expect it to have (under negation and wrap-around addition).
185      !- If all of these tests are satisfied, then the routines that use this module are portable,
186      !- even though they go beyond Fortran 90's integer model.
187     
188      IF  ( hg /= 2147483647 ) CALL ran_error('ran_init: arith assump 1 fails')
189      IF  ( hgng >= 0 )        CALL ran_error('ran_init: arith assump 2 fails')
190      IF  ( hgt+1 /= hgng )    CALL ran_error('ran_init: arith assump 3 fails')
191      IF  ( not(hg) >= 0 )     CALL ran_error('ran_init: arith assump 4 fails')
192      IF  ( not(hgng) < 0 )    CALL ran_error('ran_init: arith assump 5 fails')
193      IF  ( hg+hgng >= 0 )     CALL ran_error('ran_init: arith assump 6 fails')
194      IF  ( not(-1_isp) < 0 )  CALL ran_error('ran_init: arith assump 7 fails')
195      IF  ( not(0_isp) >= 0 )  CALL ran_error('ran_init: arith assump 8 fails')
196      IF  ( not(1_isp) >= 0 )  CALL ran_error('ran_init: arith assump 9 fails')
197     
198      IF  ( lenran > 0) THEN                          !- Reallocate space, or ...
199     
200         ranseeds => reallocate( ranseeds, length, 5)
201         ranv => reallocate( ranv, length-1)
202         new = lenran+1
203         
204      ELSE                                            !- allocate space.
205     
206         ALLOCATE(ranseeds(length,5))
207         ALLOCATE(ranv(length-1))
208         new = 1   !- Index of first location not yet initialized.
209         amm = nearest(1.0_wp,-1.0_wp)/hgng
210         !- Use of nearest is to ensure that returned random deviates are strictly lessthan 1.0.
211         IF  (amm*hgng >= 1.0 .or. amm*hgng <= 0.0)                            &
212            CALL ran_error('ran_init: arith assump 10 fails')
213           
214      END IF 
215     
216      !- Set starting values, unique by seq and vector component.
217      ranseeds(new:,1) = seq
218      ranseeds(new:,2:5)=spread(arth(new,1,size(ranseeds(new:,1))),2,4)
219     
220      DO j=1,4   !- Hash them.
221         CALL ran_hash(ranseeds(new:,j), ranseeds(new:,j+1))
222      END DO
223     
224      WHERE (ranseeds (new: ,1:3) < 0)                                         & 
225         ranseeds(new: ,1:3)=not(ranseeds(new: ,1:3))  !- Enforce nonnegativity.
226         
227      WHERE (ranseeds(new: ,4:5) == 0) ranseeds(new: ,4:5)=1 !- Enforce nonzero.
228     
229      IF  (new == 1) THEN !- Set scalar seeds.
230     
231         iran0 = ranseeds(1,1)
232         jran0 = ranseeds(1,2)
233         kran0 = ranseeds(1,3)
234         mran0 = ranseeds(1,4)
235         nran0 = ranseeds(1,5)
236         rans  = nran0
237         
238      END IF
239     
240      IF  (length > 1) THEN   !- Point to vector seeds.
241     
242         iran => ranseeds(2:,1)
243         jran => ranseeds(2:,2)
244         kran => ranseeds(2:,3)
245         mran => ranseeds(2:,4)
246         nran => ranseeds(2:,5)
247         ranv = nran
248         
249      END IF
250     
251      lenran = length
252     
253   END SUBROUTINE ran_init
254
255!------------------------------------------------------------------------------!
256! Description:
257! ------------
[1682]258!> User interface to release the workspace used by the random number routines.
[1400]259!------------------------------------------------------------------------------!
260   SUBROUTINE ran_deallocate
261   
262      IF  ( lenran > 0 ) THEN
263     
264         DEALLOCATE(ranseeds, ranv)
265         NULLIFY(ranseeds, ranv, iran, jran, kran, mran, nran)
266         lenran = 0
267         
268      END IF
269     
270   END SUBROUTINE ran_deallocate
271
272!------------------------------------------------------------------------------!
273! Description:
274! ------------
[1682]275!> User interface for seeding the random number routines.
276!> Syntax is exactly like Fortran 90's random_seed routine,
277!> with one additional argument keyword: random_sequence, set to any integer
278!> value, causes an immediate new initialization, seeded by that integer.
[1400]279!------------------------------------------------------------------------------!
280   SUBROUTINE random_seed_parallel( random_sequence, state_size, put, get )
281   
282      IMPLICIT NONE
283     
[1682]284      INTEGER(isp), OPTIONAL, INTENT(IN)  ::  random_sequence   !<
285      INTEGER(isp), OPTIONAL, INTENT(OUT) ::  state_size        !<
[1400]286     
[1682]287      INTEGER(isp), DIMENSION(:), OPTIONAL, INTENT(IN)  ::  put   !<
288      INTEGER(isp), DIMENSION(:), OPTIONAL, INTENT(OUT) ::  get   !<
[1400]289     
290      IF  ( present(state_size) ) THEN
291     
292         state_size = 5 * lenran
293         
294      ELSE IF  ( present(put) ) THEN
295     
296         IF  ( lenran == 0 ) RETURN
297         
298         ranseeds = reshape( put,shape(ranseeds) )
299         
300         WHERE (ranseeds(:,1:3) < 0) ranseeds(: ,1:3) = not(ranseeds(: ,1:3))
301         !- Enforce nonnegativity and nonzero conditions on any user-supplied seeds.
302         
303         WHERE (ranseeds(:,4:5) == 0) ranseeds(:,4:5) = 1
304         
305         iran0 = ranseeds(1,1)
306         jran0 = ranseeds(1,2)
307         kran0 = ranseeds(1,3)
308         mran0 = ranseeds(1,4)
309         nran0 = ranseeds(1,5)
310         
311      ELSE IF  ( present(get) ) THEN
312     
313         IF  (lenran == 0) RETURN
314         
315         ranseeds(1,1:5) = (/ iran0,jran0,kran0,mran0,nran0 /)
316         get = reshape( ranseeds, shape(get) )
317         
318      ELSE IF  ( present(random_sequence) ) THEN
319     
320         CALL ran_deallocate
321         seq = random_sequence
322         
323      END IF
324     
325   END SUBROUTINE random_seed_parallel
326
327!------------------------------------------------------------------------------!
328! Description:
329! ------------
[1682]330!> DES-like hashing of two 32-bit integers, using shifts,
331!> xor's, and adds to make the internal nonlinear function.
[1400]332!------------------------------------------------------------------------------!
333   SUBROUTINE ran_hash_v( il, ir )
334   
335      IMPLICIT NONE
336     
[1682]337      INTEGER(isp), DIMENSION(:), INTENT(INOUT) ::  il   !<
338      INTEGER(isp), DIMENSION(:), INTENT(INOUT) ::  ir   !<
[1400]339     
[1682]340      INTEGER(isp), DIMENSION(size(il)) ::  is   !<
[1400]341     
[1682]342      INTEGER(isp) :: j   !<
[1400]343     
344      DO j=1,4
345     
346         is = ir
347         ir = ieor( ir, ishft(ir,5) ) + 1422217823
348         ir = ieor( ir, ishft(ir,-16) ) + 1842055030
349         ir = ieor( ir, ishft(ir,9) ) + 80567781
350         ir = ieor( il, ir )
351         il = is
352      END DO
353     
354   END SUBROUTINE ran_hash_v
355
356!------------------------------------------------------------------------------!
357! Description:
358! ------------
[1682]359!> User interface to process error-messages
360!> produced by the random_number_parallel module
[1400]361!------------------------------------------------------------------------------!
362   SUBROUTINE ran_error(string)
363   
[1682]364      CHARACTER(LEN=*), INTENT(IN) ::  string   !<
[1400]365     
366      write (*,*) 'Error in module random_number_parallel: ',string
367     
368      STOP 'Program terminated by ran_error'
369     
370   END SUBROUTINE ran_error
371
372!------------------------------------------------------------------------------!
373! Description:
374! ------------
[1682]375!> Reallocates the generators state space "ranseeds" to vectors of size length.
[1400]376!------------------------------------------------------------------------------!
377   FUNCTION reallocate_iv( p, n )
378   
[1682]379      INTEGER(isp), DIMENSION(:), POINTER ::  p               !<
380      INTEGER(isp), DIMENSION(:), POINTER ::  reallocate_iv   !<
[1400]381     
[1682]382      INTEGER(isp), INTENT(IN) ::  n   !<
[1400]383     
[1682]384      INTEGER(isp) ::  nold   !<
385      INTEGER(isp) ::  ierr   !<
[1400]386     
387      ALLOCATE(reallocate_iv(n),stat=ierr)
388     
389      IF (ierr /= 0) CALL                                                      &
390         ran_error('reallocate_iv: problem in attempt to allocate memory')
391         
392      IF (.not. associated(p)) RETURN
393     
394      nold = size(p)
395     
396      reallocate_iv(1:min(nold,n)) = p(1:min(nold,n))
397     
398      DEALLOCATE(p)
399     
400   END FUNCTION reallocate_iv
401   
402   FUNCTION reallocate_im( p, n, m )
403   
[1682]404      INTEGER(isp), DIMENSION(:,:), POINTER ::  p               !<
405      INTEGER(isp), DIMENSION(:,:), POINTER ::  reallocate_im   !<
[1400]406     
[1682]407      INTEGER(isp), INTENT(IN) ::  m   !<
408      INTEGER(isp), INTENT(IN) ::  n   !<
[1400]409     
[1682]410      INTEGER(isp) ::  mold   !<
411      INTEGER(isp) ::  nold   !<
412      INTEGER(isp) ::  ierr   !<
[1400]413     
414      ALLOCATE(reallocate_im(n,m),stat=ierr)
415     
416      IF (ierr /= 0) CALL                                                      &
417         ran_error('reallocate_im: problem in attempt to allocate memory')
418         
419      IF (.not. associated(p)) RETURN
420     
421      nold = size(p,1)
422      mold = size(p,2)
423     
424      reallocate_im(1:min(nold,n),1:min(mold,m)) =                             &
425         p(1:min(nold,n),1:min(mold,m))
426         
427      DEALLOCATE(p)
428     
429   END FUNCTION reallocate_im
430
431!------------------------------------------------------------------------------!
432! Description:
433! ------------
[1682]434!> Reallocates the generators state space "ranseeds" to vectors of size length.
[1400]435!------------------------------------------------------------------------------!
436   FUNCTION arth_i(first,increment,n)
437   
[1682]438      INTEGER(isp), INTENT(IN) ::  first       !<
439      INTEGER(isp), INTENT(IN) ::  increment   !<
440      INTEGER(isp), INTENT(IN) ::  n           !<
[1400]441     
[1682]442      INTEGER(isp), DIMENSION(n) ::  arth_i    !<
[1400]443     
[1682]444      INTEGER(isp) ::  k      !<
445      INTEGER(isp) ::  k2     !<
446      INTEGER(isp) ::  temp   !<
[1400]447     
[1682]448      INTEGER(isp), PARAMETER ::  npar_arth=16   !<
449      INTEGER(isp), PARAMETER ::  npar2_arth=8   !<
[1400]450     
451      IF (n > 0) arth_i(1) = first
452     
453      IF (n <= npar_arth) THEN
454     
455         DO k=2,n
456            arth_i(k) = arth_i(k-1)+increment
457         END DO
458         
459      ELSE
460     
461         DO k=2,npar2_arth
462            arth_i(k) = arth_i(k-1) + increment
463         END DO
464         
465         temp = increment * npar2_arth
466         k = npar2_arth
467         
468         DO
469            IF (k >= n) EXIT
470            k2 = k + k
471            arth_i(k+1:min(k2,n)) = temp + arth_i(1:min(k,n-k))
472            temp = temp + temp
473            k = k2
474         END DO
475         
476      END IF
477     
478   END FUNCTION arth_i
479
480END MODULE random_generator_parallel
Note: See TracBrowser for help on using the repository browser.