OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
parit.F File Reference
#include "implicit_f.inc"
#include "lockon.inc"
#include "lockoff.inc"
#include "comlock.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine sum_6_float (jft, jlt, f, f6, n)
subroutine foat_to_6_float (jft, jlt, f, f6)
subroutine foat_to_7_float (f, f7)
subroutine double_flot_ieee (jft, jlt, i8, r8, i8f)
subroutine sum_6_float_sens (f, a, b, c, jft, jlt, f6, d, e, g, isensint)
subroutine sum_6_float_sect (f, a, b, jft, jlt, f6, d, e)

Function/Subroutine Documentation

◆ double_flot_ieee()

subroutine double_flot_ieee ( integer jft,
integer jlt,
integer*8, dimension(*) i8,
r8,
integer*8, dimension(3,*) i8f )

Definition at line 484 of file parit.F.

485C-----------------------------------------------
486C I m p l i c i t T y p e s
487C-----------------------------------------------
488#include "implicit_f.inc"
489C-----------------------------------------------
490C G l o b a l P a r a m e t e r s
491C-----------------------------------------------
492#include "mvsiz_p.inc"
493C-----------------------------------------------
494C D u m m y A r g u m e n t s
495C-----------------------------------------------
496 INTEGER JFT, JLT
497 integer*8 I8(*),I8F(3,*)
498 my_real
499 . r8(mvsiz)
500C-----------------------------------------------
501C L o c a l V a r i a b l e s
502C-----------------------------------------------
503c___________________________________________________
504 double precision
505 . r8_local,r8_deuxp43,aa
506 INTEGER*8 I8_DEUXP43
507 DATA i8_deuxp43 /'80000000000'x/
508 DATA r8_deuxp43 /'42A0000000000000'x/
509 INTEGER I
510c___________________________________________________
511C-----------------------------------------------
512C
513 DO i=jft,jlt
514c___________________________________________________
515 i8f(1,i) = r8(i)
516 aa = i8f(1,i)
517 r8_local = (r8(i) - aa) * r8_deuxp43
518 i8f(2,i) = r8_local
519 aa = i8f(2,i)
520 r8_local = (r8_local - aa) * r8_deuxp43
521 i8f(3,i) = r8_local + 0.5
522 ENDDO
523c___________________________________________________
524 RETURN
my_real
#define my_real
Definition cppsort.cpp:32

◆ foat_to_6_float()

subroutine foat_to_6_float ( integer jft,
integer jlt,
f,
double precision, dimension(6,*) f6 )

Definition at line 225 of file parit.F.

226C-----------------------------------------------
227C I m p l i c i t T y p e s
228C-----------------------------------------------
229#include "implicit_f.inc"
230C-----------------------------------------------
231C D u m m y A r g u m e n t s
232C-----------------------------------------------
233 INTEGER JFT, JLT
234C REAL
235 my_real
236 . f(*)
237 DOUBLE PRECISION F6(6,*)
238C-----------------------------------------------
239c
240c r=26 (foat_to_6_float): number of bits for the carry
241c allows to make 2^R + ~ = 67,000,000.
242c
243c m1: mask 1
244c ...
245c m6: mask 6
246c
247c m2 = m1 - 53 + r
248c m3 = m2 - 53 + r
249c m4 = m3 - 53 + r
250c m5 = m4 - 53 + r
251c m6 = m5 - 53 + r
252c
253c if r= 26 : mi = mi-1 - 27
254c
255c f1 = (f + 2^m1) - 2^m1
256c b = f - f1
257c f1 = (b + 2^m2) - 2^m2
258c d = b - f2
259c f3 = (d + 2^m3) - 2^m3
260c f4 = ((d - f3) + 2^m4) - 2^m4
261c ...
262c--------- calculation of fmax, fmin
263c fmax with r bits zero = 2^(m1-r)
264c
265c Fmin with 53 significant bits = 2^m6
266c Fmin with 1 significant bits = 2^(M6-53)
267c
268c-------- FMAX, fmin after expression
269c fmax with r bits zero ~= 2^(m1-2r)
270c
271c Fmin with 53 significant bits ~ = 2^(M6-R)
272c Fmin with 1 significant bits ~ = 2^(M6-53-R)
273c
274c 6 float r=26 m1=89 m6=-46
275c
276c fmax with r bits zero ~= 2^37 =
277c Fmin with 53 significant bits ~ = 2^(M6-R)
278c Fmin with 1 significant bits ~ = 2^(M6-53-R)
279c-------------------------------------------------------
280c A = F + twoP63
281c F4 (1) = A - TwoP63
282c b = f - f4(1)
283c c '= b + twop30
284c F4 (2) = c'- twop30
285c d = b - f4(2)
286c E = d '+ twopm3
287c F4 (3) = E - TwoPM3
288c g = d - f4(3)
289c H = G + twoPM36
290c F4 (4) = H - TwoPM36
291C-----------------------------------------------
292C L o c a l C o m m o n
293C-----------------------------------------------
294C
295C Warning - Warning - Warning - Warning - Warning - Warning
296C
297C Common to break the optimization and thread private for multithread
298C
299 COMMON /parit_var/temp1,temp2,temp3,temp4,temp5,temp6,temp7,
300 . temp11,temp12,temp13,temp14,temp15,temp16,
301 . temp17,reste
302!$OMP THREADPRIVATE(/PARIT_VAR/)
303 DOUBLE PRECISION TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,TEMP6,TEMP7,
304 . TEMP11,TEMP12,TEMP13,TEMP14,TEMP15,TEMP16,
305 . TEMP17,RESTE
306C
307C Warning - Warning - Warning - Warning - Warning - Warning
308C
309C-----------------------------------------------
310C L o c a l V a r i a b l e s
311C-----------------------------------------------
312 INTEGER I
313 DOUBLE PRECISION R8DEUXP89,R8DEUXP62,R8DEUXP35,R8TWOP8
314 DOUBLE PRECISION R8DEUXPM19,R8DEUXPM46
315 DATA r8deuxp89 /'4580000000000000'x/
316 DATA r8deuxp62 /'43D0000000000000'x/
317 DATA r8deuxp35 /'4220000000000000'x/
318 DATA r8twop8 /'4070000000000000'x/
319 DATA r8deuxpm19/'3EC0000000000000'x/
320 DATA r8deuxpm46/'3D10000000000000'x/
321
322 DO i=jft,jlt
323
324 reste = f(i)
325
326 temp1 = reste + r8deuxp89
327 f6(1,i) = temp1 - r8deuxp89
328 reste = reste - f6(1,i)
329
330 temp2 = reste + r8deuxp62
331 f6(2,i) = temp2 - r8deuxp62
332 reste = reste - f6(2,i)
333
334 temp3 = reste + r8deuxp35
335 f6(3,i) = temp3 - r8deuxp35
336 reste = reste - f6(3,i)
337
338 temp4 = reste + r8twop8
339 f6(4,i) = temp4 - r8twop8
340 reste = reste - f6(4,i)
341
342 temp5 = reste + r8deuxpm19
343 f6(5,i) = temp5 - r8deuxpm19
344 reste = reste - f6(5,i)
345
346 temp6 = reste + r8deuxpm46
347 f6(6,i) = temp6 - r8deuxpm46
348
349 ENDDO
350
351 RETURN

◆ foat_to_7_float()

subroutine foat_to_7_float ( double precision f,
double precision, dimension(7) f7 )

Definition at line 357 of file parit.F.

358C-----------------------------------------------
359C I m p l i c i t T y p e s
360C-----------------------------------------------
361#include "implicit_f.inc"
362C-----------------------------------------------
363C D u m m y A r g u m e n t s
364C-----------------------------------------------
365 DOUBLE PRECISION F,F7(7)
366C-----------------------------------------------
367c
368c r=29 (foat_to_7_float): number of bits for the carry
369c allows to make 2^R + ~ = 537,000,000.
370c
371c m1: mask 1
372c ...
373c m6: mask 6
374c
375c m2 = m1 - 53 + r
376c m3 = m2 - 53 + r
377c m4 = m3 - 53 + r
378c m5 = m4 - 53 + r
379c m6 = m5 - 53 + r
380c m7 = m6 - 53 + r
381c
382c if r= 29 : mi = mi-1 - 24
383c
384c f1 = (f + 2^m1) - 2^m1
385c b = f - f1
386c f1 = (b + 2^m2) - 2^m2
387c d = b - f2
388c f3 = (d + 2^m3) - 2^m3
389c f4 = ((d - f3) + 2^m4) - 2^m4
390c ...
391c--------- calculation of fmax, fmin
392c calculation
393c fmax with 0 bits zero = 2^m1
394c fmax with r bits zero = 2^(m1-r)
395c
396c Fmin with 53 significant bits = 2^m7
397c Fmin with 1 significant bits = 2^(m7+53)
398c
399c fmax with 0 bits zero = 5. 10^27
400c fmax with r bits zero = 9. 10^18
401c Fmin with 53 significant bits ~ = 2.2 10^-16
402c Fmin with 1 significant bits ~ = 2.4 10^-32
403c-------------------------------------------------------
404c A = F + twoP63
405c F4 (1) = A - TwoP63
406c b = f - f4(1)
407c c '= b + twop30
408c F4 (2) = c'- twop30
409c d = b - f4(2)
410c E = d '+ twopm3
411c F4 (3) = E - TwoPM3
412c g = d - f4(3)
413c H = G + twoPM36
414c F4 (4) = H - TwoPM36
415C-----------------------------------------------
416C L o c a l C o m m o n
417C-----------------------------------------------
418C
419C Warning - Warning - Warning - Warning - Warning - Warning
420C
421C Common to break the optimization and thread private for multithread
422C
423 COMMON /parit_var/temp1,temp2,temp3,temp4,temp5,temp6,temp7,
424 . temp11,temp12,temp13,temp14,temp15,temp16,
425 . temp17,reste
426!$OMP THREADPRIVATE(/PARIT_VAR/)
427 DOUBLE PRECISION TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,TEMP6,TEMP7,
428 . TEMP11,TEMP12,TEMP13,TEMP14,TEMP15,TEMP16,
429 . TEMP17,RESTE
430C
431C Warning - Warning - Warning - Warning - Warning - Warning
432C
433C-----------------------------------------------
434C L o c a l V a r i a b l e s
435C-----------------------------------------------
436 DOUBLE PRECISION DEUXP92,DEUXP68,DEUXP44 ,DEUXP20,DEUXPM4,
437 . DEUXPM28,DEUXPM52
438 DATA deuxp92 /'45B0000000000000'x/
439 DATA deuxp68 /'4430000000000000'x/
440 DATA deuxp44 /'42B0000000000000'x/
441 DATA deuxp20 /'4130000000000000'x/
442 DATA deuxpm4 /'3FB0000000000000'x/
443 DATA deuxpm28/'3e30000000000000'X/
444 DATA DEUXPM52/'3cb0000000000000'X/
445
446 TEMP1 = F + DEUXP92
447 F7(1) = TEMP1 - DEUXP92
448 RESTE = F - F7(1)
449
450 TEMP2 = RESTE + DEUXP68
451 F7(2) = TEMP2 - DEUXP68
452 RESTE = RESTE - F7(2)
453
454 TEMP3 = RESTE + DEUXP44
455 F7(3) = TEMP3 - DEUXP44
456 RESTE = RESTE - F7(3)
457
458 TEMP4 = RESTE + DEUXP20
459 F7(4) = TEMP4 - DEUXP20
460 RESTE = RESTE - F7(4)
461
462 TEMP5 = RESTE + DEUXPM4
463 F7(5) = TEMP5 - DEUXPM4
464 RESTE = RESTE - F7(5)
465
466 TEMP6 = RESTE + DEUXPM28
467 F7(6) = TEMP6 - DEUXPM28
468 RESTE = RESTE - F7(6)
469
470 TEMP7 = RESTE + DEUXPM52
471 F7(7) = TEMP7 - DEUXPM52
472
473 RETURN

◆ sum_6_float()

subroutine sum_6_float ( integer jft,
integer jlt,
f,
double precision, dimension(n,6) f6,
integer n )

Definition at line 64 of file parit.F.

65C-----------------------------------------------
66C I m p l i c i t T y p e s
67C-----------------------------------------------
68#include "implicit_f.inc"
69C-----------------------------------------------
70C D u m m y A r g u m e n t s
71C-----------------------------------------------
72 INTEGER JFT, JLT, N
73 my_real
74 . f(*)
75 DOUBLE PRECISION F6(N,6)
76C-----------------------------------------------
77c
78c r=26 (foat_to_6_float): number of bits for the carry
79c allows to make 2^R + ~ = 67,000,000.
80c
81c m1: mask 1
82c ...
83c m6: mask 6
84c
85c m2 = m1 - 53 + r
86c m3 = m2 - 53 + r
87c m4 = m3 - 53 + r
88c m5 = m4 - 53 + r
89c m6 = m5 - 53 + r
90c
91c if r= 26 : mi = mi-1 - 27
92c
93c f1 = (f + 2^m1) - 2^m1
94c b = f - f1
95c f1 = (b + 2^m2) - 2^m2
96c d = b - f2
97c f3 = (d + 2^m3) - 2^m3
98c f4 = ((d - f3) + 2^m4) - 2^m4
99c ...
100c--------- calculation of fmax, fmin
101c fmax with r bits zero = 2^(m1-r)
102c
103c Fmin with 53 significant bits = 2^m6
104c Fmin with 1 significant bits = 2^(M6-53)
105c
106c-------- FMAX, fmin after expression
107c fmax with r bits zero ~= 2^(m1-2r)
108c
109c Fmin with 53 significant bits ~ = 2^(M6-R)
110c Fmin with 1 significant bits ~ = 2^(M6-53-R)
111c
112c 6 float r=26 m1=89 m6=-46
113c
114c fmax with r bits zero ~= 2^37 =
115c Fmin with 53 significant bits ~ = 2^(M6-R)
116c Fmin with 1 significant bits ~ = 2^(M6-53-R)
117c-------------------------------------------------------
118c A = F + twoP63
119c F4 (1) = A - TwoP63
120c b = f - f4(1)
121c c '= b + twop30
122c F4 (2) = c'- twop30
123c d = b - f4(2)
124c E = d '+ twopm3
125c F4 (3) = E - TwoPM3
126c g = d - f4(3)
127c H = G + twoPM36
128c F4 (4) = H - TwoPM36
129C-----------------------------------------------
130C L o c a l C o m m o n
131C-----------------------------------------------
132C
133C Warning - Warning - Warning - Warning - Warning - Warning
134C
135C Common to break the optimization and thread private for multithread
136C
137 COMMON /parit_var/temp1,temp2,temp3,temp4,temp5,temp6,temp7,
138 . temp11,temp12,temp13,temp14,temp15,temp16,
139 . temp17,reste
140!$OMP THREADPRIVATE(/PARIT_VAR/)
141 DOUBLE PRECISION TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,TEMP6,TEMP7,
142 . TEMP11,TEMP12,TEMP13,TEMP14,TEMP15,TEMP16,
143 . TEMP17,RESTE
144C
145C Warning - Warning - Warning - Warning - Warning - Warning
146C
147C-----------------------------------------------
148C L o c a l V a r i a b l e s
149C-----------------------------------------------
150 INTEGER I
151 DOUBLE PRECISION R8DEUXP89,R8DEUXP62,R8DEUXP35,R8TWOP8
152 DOUBLE PRECISION R8DEUXPM19,R8DEUXPM46
153 DATA r8deuxp89 /'4580000000000000'x/
154 DATA r8deuxp62 /'43D0000000000000'x/
155 DATA r8deuxp35 /'4220000000000000'x/
156 DATA r8twop8 /'4070000000000000'x/
157 DATA r8deuxpm19/'3EC0000000000000'x/
158 DATA r8deuxpm46/'3D10000000000000'x/
159
160 DO i=jft,jlt
161
162 reste = f(i)
163
164 temp1 = reste + r8deuxp89
165 temp11 = temp1 - r8deuxp89
166 reste = reste - temp11
167
168 temp2 = reste + r8deuxp62
169 temp12 = temp2 - r8deuxp62
170 reste = reste - temp12
171
172 temp3 = reste + r8deuxp35
173 temp13 = temp3 - r8deuxp35
174 reste = reste - temp13
175
176 temp4 = reste + r8twop8
177 temp14 = temp4 - r8twop8
178 reste = reste - temp14
179
180 temp5 = reste + r8deuxpm19
181 temp15 = temp5 - r8deuxpm19
182 reste = reste - temp15
183
184 temp6 = reste + r8deuxpm46
185 temp16 = temp6 - r8deuxpm46
186
187 f6(1,1) = f6(1,1) + temp11
188 f6(1,2) = f6(1,2) + temp12
189 f6(1,3) = f6(1,3) + temp13
190 f6(1,4) = f6(1,4) + temp14
191 f6(1,5) = f6(1,5) + temp15
192 f6(1,6) = f6(1,6) + temp16
193
194 ENDDO
195
196 RETURN

◆ sum_6_float_sect()

subroutine sum_6_float_sect ( f,
integer a,
integer b,
integer jft,
integer jlt,
double precision, dimension(d,e) f6,
integer d,
integer e )

Definition at line 698 of file parit.F.

699C-----------------------------------------------
700C I m p l i c i t T y p e s
701C-----------------------------------------------
702#include "implicit_f.inc"
703C-----------------------------------------------
704C C o m m o n B l o c k s
705C-----------------------------------------------
706#include "comlock.inc"
707C-----------------------------------------------
708C D u m m y A r g u m e n t s
709C-----------------------------------------------
710 INTEGER JFT, JLT, A, B, D, E
711 my_real f(a,b)
712 DOUBLE PRECISION F6(D,E)
713C-----------------------------------------------
714c
715c r=26 (foat_to_6_float): number of bits for the carry
716c allows to make 2^R + ~ = 67,000,000.
717c
718c m1: mask 1
719c ...
720c m6: mask 6
721c
722c m2 = m1 - 53 + r
723c m3 = m2 - 53 + r
724c m4 = m3 - 53 + r
725c m5 = m4 - 53 + r
726c m6 = m5 - 53 + r
727c
728c if r= 26 : mi = mi-1 - 27
729c
730c f1 = (f + 2^m1) - 2^m1
731c b = f - f1
732c f1 = (b + 2^m2) - 2^m2
733c d = b - f2
734c f3 = (d + 2^m3) - 2^m3
735c f4 = ((d - f3) + 2^m4) - 2^m4
736c ...
737c--------- calculation of fmax, fmin
738c fmax with r bits zero = 2^(m1-r)
739c
740c Fmin with 53 significant bits = 2^m6
741c Fmin with 1 significant bits = 2^(M6-53)
742c
743c-------- FMAX, fmin after expression
744c fmax with r bits zero ~= 2^(m1-2r)
745c
746c Fmin with 53 significant bits ~ = 2^(M6-R)
747c Fmin with 1 significant bits ~ = 2^(M6-53-R)
748c
749c 6 float r=26 m1=89 m6=-46
750c
751c fmax with r bits zero ~= 2^37 =
752c Fmin with 53 significant bits ~ = 2^(M6-R)
753c Fmin with 1 significant bits ~ = 2^(M6-53-R)
754c-------------------------------------------------------
755c A = F + twoP63
756c F4 (1) = A - TwoP63
757c b = f - f4(1)
758c c '= b + twop30
759c F4 (2) = c'- twop30
760c d = b - f4(2)
761c E = d '+ twopm3
762c F4 (3) = E - TwoPM3
763c g = d - f4(3)
764c H = G + twoPM36
765c F4 (4) = H - TwoPM36
766C-----------------------------------------------
767C L o c a l C o m m o n
768C-----------------------------------------------
769C
770C Warning - Warning - Warning - Warning - Warning - Warning
771C
772C Common to break the optimization and thread private for multithread
773C
774 COMMON /parit_var/temp1,temp2,temp3,temp4,temp5,temp6,temp7,
775 . temp11,temp12,temp13,temp14,temp15,temp16,
776 . temp17,reste
777!$OMP THREADPRIVATE(/PARIT_VAR/)
778 DOUBLE PRECISION TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,TEMP6,TEMP7,
779 . TEMP11,TEMP12,TEMP13,TEMP14,TEMP15,TEMP16,
780 . TEMP17,RESTE
781C
782C Warning - Warning - Warning - Warning - Warning - Warning
783C
784C-----------------------------------------------
785C L o c a l V a r i a b l e s
786C-----------------------------------------------
787 INTEGER I,J
788 DOUBLE PRECISION R8DEUXP89,R8DEUXP62,R8DEUXP35,R8TWOP8
789 DOUBLE PRECISION R8DEUXPM19,R8DEUXPM46
790 DATA r8deuxp89 /'4580000000000000'x/
791 DATA r8deuxp62 /'43D0000000000000'x/
792 DATA r8deuxp35 /'4220000000000000'x/
793 DATA r8twop8 /'4070000000000000'x/
794 DATA r8deuxpm19/'3EC0000000000000'x/
795 DATA r8deuxpm46/'3D10000000000000'x/
796 DO i= 1,a
797 DO j=jft,jlt
798
799 reste = f(i,j)
800
801 temp1 = reste + r8deuxp89
802 temp11 = temp1 - r8deuxp89
803 reste = reste - temp11
804
805 temp2 = reste + r8deuxp62
806 temp12 = temp2 - r8deuxp62
807 reste = reste - temp12
808
809 temp3 = reste + r8deuxp35
810 temp13 = temp3 - r8deuxp35
811 reste = reste - temp13
812
813 temp4 = reste + r8twop8
814 temp14 = temp4 - r8twop8
815 reste = reste - temp14
816
817 temp5 = reste + r8deuxpm19
818 temp15 = temp5 - r8deuxpm19
819 reste = reste - temp15
820
821 temp6 = reste + r8deuxpm46
822 temp16 = temp6 - r8deuxpm46
823
824#include "lockon.inc"
825 f6(i,1) = f6(i,1) + temp11
826 f6(i,2) = f6(i,2) + temp12
827 f6(i,3) = f6(i,3) + temp13
828 f6(i,4) = f6(i,4) + temp14
829 f6(i,5) = f6(i,5) + temp15
830 f6(i,6) = f6(i,6) + temp16
831#include "lockoff.inc"
832
833 ENDDO
834 ENDDO
835
836 RETURN

◆ sum_6_float_sens()

subroutine sum_6_float_sens ( f,
integer a,
integer b,
integer c,
integer jft,
integer jlt,
double precision, dimension(d,e,g) f6,
integer d,
integer e,
integer g,
integer, dimension(*) isensint )

Definition at line 539 of file parit.F.

540C-----------------------------------------------
541C I m p l i c i t T y p e s
542C-----------------------------------------------
543#include "implicit_f.inc"
544C-----------------------------------------------
545C C o m m o n B l o c k s
546C-----------------------------------------------
547#include "comlock.inc"
548C-----------------------------------------------
549C D u m m y A r g u m e n t s
550C-----------------------------------------------
551 INTEGER JFT, JLT, A, B, C, D, E, G, ISENSINT(*)
552C REAL
553 my_real
554 . f(a,b,c)
555 DOUBLE PRECISION F6(D,E,G)
556C-----------------------------------------------
557c
558c r=26 (foat_to_6_float): number of bits for the carry
559c allows to make 2^R + ~ = 67,000,000.
560c
561c m1: mask 1
562c ...
563c m6: mask 6
564c
565c m2 = m1 - 53 + r
566c m3 = m2 - 53 + r
567c m4 = m3 - 53 + r
568c m5 = m4 - 53 + r
569c m6 = m5 - 53 + r
570c
571c if r= 26 : mi = mi-1 - 27
572c
573c f1 = (f + 2^m1) - 2^m1
574c b = f - f1
575c f1 = (b + 2^m2) - 2^m2
576c d = b - f2
577c f3 = (d + 2^m3) - 2^m3
578c f4 = ((d - f3) + 2^m4) - 2^m4
579c ...
580c--------- calculation of fmax, fmin
581c fmax with r bits zero = 2^(m1-r)
582c
583c Fmin with 53 significant bits = 2^m6
584c Fmin with 1 significant bits = 2^(M6-53)
585c
586c-------- FMAX, fmin after expression
587c fmax with r bits zero ~= 2^(m1-2r)
588c
589c Fmin with 53 significant bits ~ = 2^(M6-R)
590c Fmin with 1 significant bits ~ = 2^(M6-53-R)
591c
592c 6 float r=26 m1=89 m6=-46
593c
594c fmax with r bits zero ~= 2^37 =
595c Fmin with 53 significant bits ~ = 2^(M6-R)
596c Fmin with 1 significant bits ~ = 2^(M6-53-R)
597c-------------------------------------------------------
598c A = F + twoP63
599c F4 (1) = A - TwoP63
600c b = f - f4(1)
601c c '= b + twop30
602c F4 (2) = c'- twop30
603c d = b - f4(2)
604c E = d '+ twopm3
605c F4 (3) = E - TwoPM3
606c g = d - f4(3)
607c H = G + twoPM36
608c F4 (4) = H - TwoPM36
609C-----------------------------------------------
610C L o c a l C o m m o n
611C-----------------------------------------------
612C
613C Warning - Warning - Warning - Warning - Warning - Warning
614C
615C Common to break the optimization and thread private for multithread
616C
617 COMMON /parit_var/temp1,temp2,temp3,temp4,temp5,temp6,temp7,
618 . temp11,temp12,temp13,temp14,temp15,temp16,
619 . temp17,reste
620!$OMP THREADPRIVATE(/PARIT_VAR/)
621 DOUBLE PRECISION TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,TEMP6,TEMP7,
622 . TEMP11,TEMP12,TEMP13,TEMP14,TEMP15,TEMP16,
623 . TEMP17,RESTE
624C
625C Warning - Warning - Warning - Warning - Warning - Warning
626C
627C-----------------------------------------------
628C L o c a l V a r i a b l e s
629C-----------------------------------------------
630 INTEGER I,J,K
631 DOUBLE PRECISION R8DEUXP89,R8DEUXP62,R8DEUXP35,R8TWOP8
632 DOUBLE PRECISION R8DEUXPM19,R8DEUXPM46
633 DATA r8deuxp89 /'4580000000000000'x/
634 DATA R8DEUXP62 /'43d0000000000000'x/
635 DATA R8DEUXP35 /'4220000000000000'x/
636 DATA R8TWOP8 /'4070000000000000'x/
637 DATA R8DEUXPM19/'3ec0000000000000'x/
638 DATA R8DEUXPM46/'3d10000000000000'x/
639
640 DO I= 1,A
641 IF(ISENSINT(I) /=0)THEN
642 DO J= 1,B
643 DO K=JFT,JLT
644
645 RESTE = F(I,J,K)
646
647 TEMP1 = RESTE + R8DEUXP89
648 TEMP11 = TEMP1 - R8DEUXP89
649 RESTE = RESTE - TEMP11
650
651 TEMP2 = RESTE + R8DEUXP62
652 TEMP12 = TEMP2 - R8DEUXP62
653 RESTE = RESTE - TEMP12
654
655 TEMP3 = RESTE + R8DEUXP35
656 TEMP13 = TEMP3 - R8DEUXP35
657 RESTE = RESTE - TEMP13
658
659 TEMP4 = RESTE + R8TWOP8
660 TEMP14 = TEMP4 - R8TWOP8
661 RESTE = RESTE - TEMP14
662
663 TEMP5 = RESTE + R8DEUXPM19
664 TEMP15 = TEMP5 - R8DEUXPM19
665 RESTE = RESTE - TEMP15
666
667 TEMP6 = RESTE + R8DEUXPM46
668 TEMP16 = TEMP6 - R8DEUXPM46
669
670#include "lockon.inc"
671 F6(J,1,ISENSINT(I)) = F6(J,1,ISENSINT(I)) + TEMP11
672 F6(J,2,ISENSINT(I)) = F6(J,2,ISENSINT(I)) + TEMP12
673 F6(J,3,ISENSINT(I)) = F6(J,3,ISENSINT(I)) + TEMP13
674 F6(J,4,ISENSINT(I)) = F6(J,4,ISENSINT(I)) + TEMP14
675 F6(J,5,ISENSINT(I)) = F6(J,5,ISENSINT(I)) + TEMP15
676 F6(J,6,ISENSINT(I)) = F6(J,6,ISENSINT(I)) + TEMP16
677#include "lockoff.inc"
678
679 ENDDO
680 ENDDO
681 ENDIF
682 ENDDO
683
684 RETURN