OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
sms_proj.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| sms_inist ../engine/source/ams/sms_proj.F
25!||--- called by ------------------------------------------------------
26!|| sms_pcg ../engine/source/ams/sms_pcg.F
27!||--- calls -----------------------------------------------------
28!|| mav_mm ../engine/source/implicit/produt_v.F
29!|| my_barrier ../engine/source/system/machine.F
30!|| sms_mam_nm ../engine/source/ams/sms_proj.F
31!|| sms_mav_lt2 ../engine/source/ams/sms_pcg.F
32!|| startime ../engine/source/system/timer_mod.F90
33!|| stoptime ../engine/source/system/timer_mod.F90
34!||--- uses -----------------------------------------------------
35!|| sms_pcg_proj ../engine/share/modules/sms_mod.F
36!|| timer_mod ../engine/source/system/timer_mod.F90
37!||====================================================================
38 SUBROUTINE sms_inist(TIMERS,
39 1 IADK ,JDIK ,DIAG_K ,LT_K ,ITASK ,
40 2 NODFT1_SMS,NODLT1_SMS,INDX1_SMS,NODNX_SMS,IAD_ELEM ,
41 3 FR_ELEM ,WEIGHT ,JADI_SMS ,JDII_SMS ,LTI_SMS ,
42 4 ISKYI_SMS ,MSKYI_SMS ,FR_SMS ,FR_RMS ,LIST_SMS ,
43 5 LIST_RMS ,MSKYI_FI_SMS ,VFI ,IMV ,MV ,
44 6 MV6 ,MW6 ,MS ,NODFT ,NODLT )
45C-----------------------------------------------
46C M o d u l e s
47C-----------------------------------------------
48 USE timer_mod
49 USE sms_pcg_proj
50C-----------------------------------------------
51C I m p l i c i t T y p e s
52C-----------------------------------------------
53#include "implicit_f.inc"
54C-----------------------------------------------
55C C o m m o n B l o c k s
56C-----------------------------------------------
57#include "com01_c.inc"
58#include "sms_c.inc"
59#include "timeri_c.inc"
60#include "units_c.inc"
61#include "com04_c.inc"
62C-----------------------------------------------
63C D u m m y A r g u m e n t s
64C-----------------------------------------------
65 TYPE(timer_), INTENT(INOUT) :: TIMERS
66 INTEGER NODFT, NODLT, ITASK, IADK(*) ,JDIK(*),
67 . NODFT1_SMS,NODLT1_SMS,INDX1_SMS(*), NODNX_SMS(*),
68 . IAD_ELEM(2,NSPMD+1) ,FR_ELEM(*),WEIGHT(*),
69 . JADI_SMS(*),JDII_SMS(*),
70 . ISKYI_SMS(LSKYI_SMS,*),FR_SMS(NSPMD+1),FR_RMS(NSPMD+1),
71 . list_sms(*), list_rms(*), imv(*)
72 my_real diag_k(*), lt_k(*) ,lti_sms(*), mskyi_sms(*),mskyi_fi_sms(*), vfi(*), mv(*), ms(*)
73 DOUBLE PRECISION MV6(6,3,*), MW6(6,3,*)
74C-----------------------------------------------
75c FUNCTION: initialization of S,T of Projection
76c
77c Note:
78c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
79c
80c TYPE NAME FUNCTION
81c I NUMNOD,NNZ - dimension of [K] and number of non zero (complete matrix)
82c I IADK,JDIK - indice arrays for compressed row(col.) format of [K]
83c I DIAG_K(NUMNOD) - diagonal terms of [K]
84c I LT_K(NNZ) - [K]
85c O Proj_S(NUMNOD,M_VS) - [S] reduced small Eigenvectors
86c O Proj_T(NUMNOD,M_VS) - [T] =[K][S]
87C-----------------------------------------------
88C L o c a l V a r i a b l e s
89C-----------------------------------------------
90#if !defined(WITHOUT_LINALG)
91 CHARACTER JOBZ, UPLO
92 INTEGER I,J,IT,IP,NLIM,ND,IUPD,IPRI,IERROR,NNZI,M,F_DDLI,L_DDLI,INFO,LW,INORM, M_VS1
93 my_real WORK(3*M_VS_SMS+9),W(M_VS_SMS+3)
94C---------------------
95 CALL MY_BARRIER
96C---------------------
97 m_vs1 = nupdtl_sms+3
98C---------------------
99C T=[K][S]
100C---------------------
101 DO m = 1,m_vs1
102 proj_t(nodft:nodlt,m)=zero
103 END DO !M = 1,M_VS1
104C----------------------
105 CALL my_barrier
106C---------------------
107 IF(imonm>0.AND.itask==0)CALL startime(timers,71)
108 DO m = 1,m_vs1
109 CALL sms_mav_lt2(timers,
110 1 nodft ,nodlt ,numnod ,iadk ,jdik ,
111 2 itask ,diag_k ,lt_k ,proj_s(1,m),proj_t(1,m),
112 3 nodft1_sms,nodlt1_sms,indx1_sms,nodnx_sms,iad_elem ,
113 4 fr_elem ,weight ,jadi_sms ,jdii_sms ,lti_sms ,
114 5 iskyi_sms ,mskyi_sms ,fr_sms ,fr_rms ,list_sms ,
115 6 list_rms ,mskyi_fi_sms ,vfi ,imv ,mv ,
116 7 mv6 ,mw6 )
117C----------------------
118 CALL my_barrier
119C---------------------
120 END DO !M = 1,M_VS1
121 IF(imonm>0.AND.itask==0)CALL stoptime(timers,71)
122C----------------------
123C [k0]=[S]^t[T]
124C---------------------
125 IF(imonm>0.AND.itask==0)CALL startime(timers,72)
126 CALL sms_mam_nm(nodft ,nodlt ,numnod,m_vs1,proj_s ,
127 . proj_t ,proj_k ,weight ,itask )
128 IF(imonm>0.AND.itask==0)CALL stoptime(timers,72)
129C----------------------
130 CALL my_barrier
131C---------------------
132C ([k0]-lamda(i)[m0])*phi(i)=0; Rather ([k0]-lamda(i)[I])*phi(i)=0
133C---------------------
134 IF (itask==0) THEN
135 jobz='V'
136 uplo='U'
137 lw=3*m_vs_sms+9
138#ifdef MYREAL8
139 CALL dsyev(jobz, uplo, m_vs1,proj_k, m_vs1,
140 . w, work, lw, info)
141#else
142 CALL ssyev(jobz, uplo, m_vs1,proj_k, m_vs1,
143 . w, work, lw, info)
144#endif
145C----------------------
146C [S]<-[S][phi]
147C---------------------
148 CALL mav_mm(numnod ,m_vs1 ,proj_s ,proj_k ,itask )
149C----------------------
150C [T]<-[T][phi]
151C---------------------
152 CALL mav_mm(numnod ,m_vs1 ,proj_t ,proj_k ,itask )
153C----------------------
154C [LAMDA]^-1<- 1.0/lamda(i)
155C---------------------
156 DO i=1,m_vs1
157 proj_la_1(i)= one/sign(max(em20,abs(w(i))),w(i))
158 ENDDO
159
160 if (ncprisms/=0) then
161 write(iout,*)' ** INFO ** EIGENVALUES =',(one/proj_la_1(i),i=1,m_vs_sms)
162 endif
163C
164 END IF !(ITASK==0) THEN
165#endif
166 RETURN
167 END
168!||====================================================================
169!|| sms_inix ../engine/source/ams/sms_proj.F
170!||--- called by ------------------------------------------------------
171!|| sms_pcg ../engine/source/ams/sms_pcg.F
172!||--- calls -----------------------------------------------------
173!|| my_barrier ../engine/source/system/machine.F
174!|| sms_mav_mn ../engine/source/ams/sms_proj.F
175!|| sms_mav_nm ../engine/source/ams/sms_proj.F
176!|| startime ../engine/source/system/timer_mod.F90
177!|| stoptime ../engine/source/system/timer_mod.F90
178!||--- uses -----------------------------------------------------
179!|| sms_pcg_proj ../engine/share/modules/sms_mod.F
180!|| timer_mod ../engine/source/system/timer_mod.F90
181!||====================================================================
182 SUBROUTINE sms_inix(TIMERS, NODFT,NODLT,NUMNOD,X ,R ,WEIGHT,ITASK ,
183 . DIAG_SMS)
184C-----------------------------------------------
185C M o d u l e s
186C-----------------------------------------------
187 USE timer_mod
188 USE sms_pcg_proj
189C-----------------------------------------------
190C I m p l i c i t T y p e s
191C-----------------------------------------------
192#include "implicit_f.inc"
193C-----------------------------------------------
194C C o m m o n B l o c k s
195C-----------------------------------------------
196#include "sms_c.inc"
197#include "timeri_c.inc"
198C-----------------------------------------------
199C D u m m y A r g u m e n t s
200C-----------------------------------------------
201 TYPE(timer_), intent(inout) :: TIMERS
202 INTEGER NODFT,NODLT,NUMNOD,ITASK,WEIGHT(*)
203 my_real X(3,*), R(3,*), DIAG_SMS(*)
204C-----------------------------------------------
205c FUNCTION: initialization of X0=[S][LAMDA]^-1[S]^t{R}
206c
207c Note:
208c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
209c
210c TYPE NAME FUNCTION
211c I NUMNOD - equation dimension
212c I NPV - projection vector number
213c I WEIGHT(*) - itag for each node of subdomains
214c I NODFT,NODLT,ITASK - id in each ITASK:thread id (//)
215c I R(3,NUMNOD) - right-hand vector
216c O X(3,NUMNOD) - X0
217C-----------------------------------------------
218C L o c a l V a r i a b l e s
219C-----------------------------------------------
220 INTEGER I,J,M,NPV, I3, I2, I1
221 my_real
222 . RSAV(3,NUMNOD), UNS
223C----------------------
224 NPV = nupdtl_sms
225C----------------------
226 DO i=nodft,nodlt
227 rsav(1,i)=r(1,i)
228 rsav(2,i)=r(2,i)
229 rsav(3,i)=r(3,i)
230 IF(diag_sms(i)/=zero)THEN
231 uns=one/sqrt(diag_sms(i))
232 r(1,i)=r(1,i)*uns
233 r(2,i)=r(2,i)*uns
234 r(3,i)=r(3,i)*uns
235 END IF
236 END DO
237C----------------------
238C {W}=[S]^t{R}
239C---------------------
240 IF(imonm>0.AND.itask==0)CALL startime(timers,72)
241 CALL sms_mav_nm(nodft,nodlt,numnod ,npv ,proj_s ,
242 . r ,proj_w,weight,itask )
243 IF(imonm>0.AND.itask==0)CALL stoptime(timers,72)
244C----------------------
245 CALL my_barrier
246C----------------------
247 IF (itask == 0) THEN
248C---------------------
249C [LAMDA]^-1{W}
250C---------------------
251 DO i=1,npv
252 i3=3*i
253 i2=i3-1
254 i1=i3-2
255 proj_w(i3)=proj_w(i3)*proj_la_1(i)
256 proj_w(i2)=proj_w(i2)*proj_la_1(i)
257 proj_w(i1)=proj_w(i1)*proj_la_1(i)
258 ENDDO
259C---------------------
260C {X0}=[S]{W}
261C---------------------
262 IF(imonm>0.AND.itask==0)CALL startime(timers,73)
263 CALL sms_mav_mn(numnod ,npv ,proj_s ,proj_w ,x ,itask )
264 IF(imonm>0.AND.itask==0)CALL stoptime(timers,73)
265C----------------------
266 END IF !(itask ==0) THEN
267C----------------------
268 CALL my_barrier
269C----------------------
270 DO i=nodft,nodlt
271 r(1,i)=rsav(1,i)
272 r(2,i)=rsav(2,i)
273 r(3,i)=rsav(3,i)
274 IF(diag_sms(i)/=zero)THEN
275 uns=one/sqrt(diag_sms(i))
276 x(1,i)=x(1,i)*uns
277 x(2,i)=x(2,i)*uns
278 x(3,i)=x(3,i)*uns
279 END IF
280 END DO
281C----------------------
282 CALL my_barrier
283C----------------------
284 RETURN
285 END
286!||====================================================================
287!|| sms_pro_p ../engine/source/ams/sms_proj.F
288!||--- called by ------------------------------------------------------
289!|| sms_pcg ../engine/source/ams/sms_pcg.F
290!||--- calls -----------------------------------------------------
291!|| my_barrier ../engine/source/system/machine.F
292!|| sms_mav_mn ../engine/source/ams/sms_proj.F
293!|| sms_mav_nm ../engine/source/ams/sms_proj.F
294!|| startime ../engine/source/system/timer_mod.F90
295!|| stoptime ../engine/source/system/timer_mod.F90
296!||--- uses -----------------------------------------------------
297!|| sms_pcg_proj ../engine/share/modules/sms_mod.F
298!|| timer_mod ../engine/source/system/timer_mod.F90
299!||====================================================================
300 SUBROUTINE sms_pro_p(TIMERS, NODFT ,NODLT ,NUMNOD ,P ,WEIGHT,ITASK ,
301 . PJ ,DIAG_SMS)
302C-----------------------------------------------
303C M o d u l e s
304C-----------------------------------------------
305 USE timer_mod
306 USE sms_pcg_proj
307C-----------------------------------------------
308C I m p l i c i t T y p e s
309C-----------------------------------------------
310#include "implicit_f.inc"
311C-----------------------------------------------
312C C o m m o n B l o c k s
313C-----------------------------------------------
314#include "sms_c.inc"
315#include "timeri_c.inc"
316C-----------------------------------------------
317C D u m m y A r g u m e n t s
318C-----------------------------------------------
319 TYPE(timer_), INTENT(inout) :: TIMERS
320 INTEGER NODFT ,NODLT ,NUMNOD ,ITASK,WEIGHT(*)
321 my_real P(3,*) ,PJ(3,*), DIAG_SMS(*)
322C-----------------------------------------------
323c FUNCTION: Projection of {p}={p}-[S][LAMDA]^-1[T]^t{p}
324c
325c Note:
326c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
327c
328c TYPE NAME FUNCTION
329c I NUMNOD - equation dimension
330c I NPV - projection vector number
331c I WEIGHT(*) - itag for each node of subdomains
332c I NODFT,NODLT,ITASK - id in each ITASK:thread id (//)
333c IO P(3,NUMNOD) - PCG p vector
334C-----------------------------------------------
335C L o c a l V a r i a b l e s
336C-----------------------------------------------
337 INTEGER I,J,NPV, I3, I2, I1
338 my_real
339 . S, UNS
340C----------------------
341 NPV = nupdtl_sms
342C----------------------
343 DO i=nodft,nodlt
344 s=sqrt(diag_sms(i))
345 p(1,i)=p(1,i)*s
346 p(2,i)=p(2,i)*s
347 p(3,i)=p(3,i)*s
348 END DO
349C----------------------
350 CALL my_barrier
351C----------------------
352C {W}=[T]^t{p}
353C---------------------
354 IF(imonm>0.AND.itask==0)CALL startime(timers,73)
355 CALL sms_mav_nm(nodft,nodlt,numnod ,npv ,proj_t ,
356 . p ,proj_w ,weight,itask )
357 IF(imonm>0.AND.itask==0)CALL stoptime(timers,73)
358C----------------------
359 CALL my_barrier
360C---------------------
361C [LAMDA]^-1{W}
362C---------------------
363 IF (itask==0) THEN
364 DO i=1,npv
365 i3=3*i
366 i2=i3-1
367 i1=i3-2
368 proj_w(i3)=proj_w(i3)*proj_la_1(i)
369 proj_w(i2)=proj_w(i2)*proj_la_1(i)
370 proj_w(i1)=proj_w(i1)*proj_la_1(i)
371 ENDDO
372C----------------------
373C {p}=[S]{W}
374C---------------------
375 IF(imonm>0.AND.itask==0)CALL startime(timers,73)
376 CALL sms_mav_mn(numnod,npv ,proj_s ,proj_w ,pj ,itask )
377 IF(imonm>0.AND.itask==0)CALL stoptime(timers,73)
378 END IF
379C----------------------
380 CALL my_barrier
381C----------------------
382 DO i=nodft,nodlt
383 p(1,i)=p(1,i)-pj(1,i)
384 p(2,i)=p(2,i)-pj(2,i)
385 p(3,i)=p(3,i)-pj(3,i)
386 IF(diag_sms(i)/=zero)THEN
387 uns=one/sqrt(diag_sms(i))
388 p(1,i)=p(1,i)*uns
389 p(2,i)=p(2,i)*uns
390 p(3,i)=p(3,i)*uns
391 END IF
392 ENDDO
393C----------------------
394 CALL my_barrier
395C----------------------
396C
397 RETURN
398 END
399!||====================================================================
400!|| sms_updst ../engine/source/ams/sms_proj.F
401!||--- called by ------------------------------------------------------
402!|| sms_pcg ../engine/source/ams/sms_pcg.F
403!||--- calls -----------------------------------------------------
404!|| my_barrier ../engine/source/system/machine.F
405!||--- uses -----------------------------------------------------
406!|| sms_pcg_proj ../engine/share/modules/sms_mod.F
407!||====================================================================
408 SUBROUTINE sms_updst(
409 1 IADK ,JDIK ,DIAG_K ,LT_K ,ITASK ,
410 2 NODFT1_SMS,NODLT1_SMS,INDX1_SMS,NODNX_SMS,IAD_ELEM ,
411 3 FR_ELEM ,WEIGHT ,JADI_SMS ,JDII_SMS ,LTI_SMS ,
412 4 ISKYI_SMS ,MSKYI_SMS ,FR_SMS ,FR_RMS ,LIST_SMS ,
413 5 LIST_RMS ,MSKYI_FI_SMS ,VFI ,IMV ,MV ,
414 6 MV6 ,MW6 ,MS ,U ,P ,
415 7 Y ,NODFT ,NODLT ,KINET )
416C-----------------------------------------------
417C M o d u l e s
418C-----------------------------------------------
419 USE sms_pcg_proj
420C-----------------------------------------------
421C I m p l i c i t T y p e s
422C-----------------------------------------------
423#include "implicit_f.inc"
424C-----------------------------------------------
425C C o m m o n B l o c k s
426C-----------------------------------------------
427#include "com01_c.inc"
428#include "sms_c.inc"
429C-----------------------------------------------
430C D u m m y A r g u m e n t s
431C-----------------------------------------------
432 INTEGER NODFT, NODLT, ITASK, IADK(*) ,JDIK(*),
433 . NODFT1_SMS,NODLT1_SMS,INDX1_SMS(*), NODNX_SMS(*),
434 . iad_elem(2,nspmd+1) ,fr_elem(*),weight(*),
435 . jadi_sms(*),jdii_sms(*),
436 . iskyi_sms(lskyi_sms,*),fr_sms(nspmd+1),fr_rms(nspmd+1),
437 . list_sms(*), list_rms(*), imv(*), kinet(*)
438 my_real
439 . diag_k(*), lt_k(*) ,lti_sms(*), mskyi_sms(*),
440 . mskyi_fi_sms(*), vfi(*), mv(*), ms(*), u(3,*), p(3,*), y(3,*)
441 DOUBLE PRECISION MV6(6,*), MW6(6,*)
442C-----------------------------------------------
443c FUNCTION: update S,T of Projection
444c
445c Note:
446c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
447c
448c TYPE NAME FUNCTION
449c I NUMNOD,NNZ - dimension of [K] and number of non zero (complete matrix)
450c I IADK,JDIK - indice arrays for compressed row(col.) format of [K]
451c I DIAG_K(NUMNOD) - diagonal terms of [K]
452c I LT_K(NNZ) - [K]
453c O Proj_S(NUMNOD,M_VS) - [S] reduced small Eigenvectors
454c O Proj_T(NUMNOD,M_VS) - [T] =[K][S]
455C-----------------------------------------------
456C L o c a l V a r i a b l e s
457C-----------------------------------------------
458 CHARACTER JOBZ, UPLO
459 INTEGER I,J,N,IT,IP,NLIM,ND,IUPD,IPRI,IERROR,NNZI,M,
460 . INFO,LW,M_VS1,INORM,NP
461 my_real
462 . WORK(3*M_VS_SMS+9), W(M_VS_SMS+3), S
463C------M_VS input one -NUPDTL_SMS: activated ---------------
464 IF (NUPDTL_SMS == 0) return
465C----------------------
466 CALL my_barrier
467C---------------------
468 m_vs1 = nupdtl_sms + 3
469C------add previous solution U ; default : aleatory updated w/ 1 vector x
470 DO n=nodft,nodlt
471 IF(kinet(n)==0.AND.nodnx_sms(n)/=0)THEN
472 s=sqrt(diag_k(n))
473 proj_s(n,nupdtl_sms+1)=u(1,n)*s
474 proj_s(n,nupdtl_sms+2)=u(2,n)*s
475 proj_s(n,nupdtl_sms+3)=u(3,n)*s
476 ELSE
477 proj_s(n,nupdtl_sms+1)=zero
478 proj_s(n,nupdtl_sms+2)=zero
479 proj_s(n,nupdtl_sms+3)=zero
480 END IF
481 ENDDO
482C----------------------
483 CALL my_barrier
484C---------------------
485 RETURN
486 END
487!||====================================================================
488!|| sms_inisi ../engine/source/ams/sms_proj.F
489!||--- called by ------------------------------------------------------
490!|| sms_pcg ../engine/source/ams/sms_pcg.F
491!||--- calls -----------------------------------------------------
492!|| my_barrier ../engine/source/system/machine.F
493!|| sms_inis ../engine/source/ams/sms_proj.F
494!|| sms_mortho_gs ../engine/source/ams/sms_proj.F
495!|| spmd_exch_sms ../engine/source/mpi/ams/spmd_exch_sms.F
496!||--- uses -----------------------------------------------------
497!|| sms_pcg_proj ../engine/share/modules/sms_mod.F
498!||====================================================================
499 SUBROUTINE sms_inisi(
500 1 IADK ,JDIK ,DIAG_K ,LT_K ,ITASK ,
501 2 NODFT1_SMS,NODLT1_SMS,INDX1_SMS,NODNX_SMS,IAD_ELEM ,
502 3 FR_ELEM ,WEIGHT ,JADI_SMS ,JDII_SMS ,LTI_SMS ,
503 4 ISKYI_SMS ,MSKYI_SMS ,FR_SMS ,FR_RMS ,LIST_SMS ,
504 5 LIST_RMS ,MSKYI_FI_SMS ,VFI ,IMV ,MV ,
505 6 MV6 ,MW6 ,MS ,NODFT ,NODLT ,
506 7 PREC_SMS ,KINET )
507C-----------------------------------------------
508C M o d u l e s
509C-----------------------------------------------
510 USE sms_pcg_proj
511C-----------------------------------------------
512C I m p l i c i t T y p e s
513C-----------------------------------------------
514#include "implicit_f.inc"
515C-----------------------------------------------
516C C o m m o n B l o c k s
517C-----------------------------------------------
518#include "com01_c.inc"
519#include "com04_c.inc"
520#include "sms_c.inc"
521C-----------------------------------------------
522C D u m m y A r g u m e n t s
523C-----------------------------------------------
524 INTEGER NODFT, NODLT, ITASK, IADK(*) ,JDIK(*),
525 . NODFT1_SMS,NODLT1_SMS,INDX1_SMS(*), NODNX_SMS(*),
526 . IAD_ELEM(2,NSPMD+1) ,FR_ELEM(*),WEIGHT(*),
527 . JADI_SMS(*),JDII_SMS(*),
528 . ISKYI_SMS(LSKYI_SMS,*),FR_SMS(NSPMD+1),FR_RMS(NSPMD+1),
529 . LIST_SMS(*), LIST_RMS(*), IMV(*), KINET(*)
530 my_real DIAG_K(*), LT_K(*) ,LTI_SMS(*), MSKYI_SMS(*),
531 . MSKYI_FI_SMS(*), VFI(*), MV(*), MS(*), PREC_SMS(*)
532 DOUBLE PRECISION MV6(6,3,*), MW6(6,3,*)
533C-----------------------------------------------
534c FUNCTION: initialization of S,by M_VS PCG iterations
535c
536c Note:
537c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
538c
539c TYPE NAME FUNCTION
540c I NUMNOD,NNZ - dimension of [K] and number of non zero (complete matrix)
541c I IADK,JDIK - indice arrays for compressed row(col.) format of [K]
542c I DIAG_K(NUMNOD) - diagonal terms of [K]
543c I LT_K(NNZ) - [K]
544c O Proj_S(NUMNOD,M_VS) - [S] reduced small Eigenvectors
545C-----------------------------------------------
546C L o c a l V a r i a b l e s
547C-----------------------------------------------
548 INTEGER I,J,IT,IP,NLIM,ND,IUPD,IPRI,IERROR,NNZI,M,
549 . INFO,LW,INORM,NPV,ITP,SIZE,LENR,N
550C---------------------
551 NPV=min(numnod-3,m_vs_sms)
552 nupdtl_sms=npv
553 npv=npv+3
554C
555 IF (ncg_run_sms == 0) THEN
556C---------------------
557 iupd = 0
558 IF(itask==0)THEN
559 CALL sms_inis(numnod,1 , numnod,1 ,npv ,proj_s ,
560 . nodnx_sms,kinet )
561C projeter PROJ_S sur cond cin. !!!
562 END IF
563C----------------------
564 CALL my_barrier
565C---------------------
566 IF(nspmd > 1) THEN
567 IF(itask == 0)THEN
568 SIZE = 1
569 lenr = iad_elem(1,nspmd+1)-iad_elem(1,1)
570 DO i=1,npv
571 CALL spmd_exch_sms(proj_s(1,i),nodnx_sms,iad_elem,fr_elem,
572 . SIZE,lenr)
573 END DO
574 END IF
575 END IF
576C--------matrix GS orthonalization and normalized
577 CALL sms_mortho_gs(nodft ,nodlt ,numnod,1 ,npv,
578 . proj_s ,weight ,itask )
579 ELSE
580C
581C projeter PROJ_S sur cond cin. !!!
582 DO j=1,npv
583 DO n=nodft,nodlt
584 IF(kinet(n)/=0.OR.nodnx_sms(n)==0)THEN
585 proj_s(n,j)=zero
586 END IF
587 ENDDO
588 ENDDO
589C----------------------
590 CALL my_barrier
591C---------------------
592C--------matrix GS orthonalization and normalized
593 CALL sms_mortho_gs(nodft ,nodlt ,numnod,1 ,npv,
594 . proj_s ,weight ,itask )
595 END IF
596C--------------------
597 CALL my_barrier
598C--------------------
599 RETURN
600 END
601!||====================================================================
602!|| sms_inis ../engine/source/ams/sms_proj.F
603!||--- called by ------------------------------------------------------
604!|| sms_inisi ../engine/source/ams/sms_proj.F
605!||====================================================================
606 SUBROUTINE sms_inis(NUMNOD,NODFT ,NODLT, NPF, NPL, S ,
607 . NODNX_SMS,KINET )
608C-----------------------------------------------
609C I m p l i c i t T y p e s
610C-----------------------------------------------
611#include "implicit_f.inc"
612C-----------------------------------------------
613C D u m m y A r g u m e n t s
614C-----------------------------------------------
615 INTEGER NUMNOD, NODFT, NODLT, NPF, NPL,
616 . nodnx_sms(*), kinet(*)
617 my_real s(numnod,*)
618C-----------------------------------------------
619c FUNCTION: initialization of [S]
620c
621c Note:
622c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
623c
624c TYPE NAME FUNCTION
625c I NODFT, NODLT - equation dimension divised by Nthead
626c I NPF,NPL - projection vector number (first to last)
627c I NUMNOD - equation dimension
628c I S(NUMNOD,NPV) - S-Matrix
629c I NODNX_SMS() -
630c I KINET() -
631C-----------------------------------------------
632C L o c a l V a r i a b l e s
633C-----------------------------------------------
634 INTEGER I,J,N
635 my_real
636 . ALEAT
637 EXTERNAL ALEAT
638C---------------------
639 DO j=npf,npl
640 DO n=nodft, nodlt
641 IF(kinet(n)==0.AND.nodnx_sms(n)/=0)THEN
642 s(n,j)=aleat()
643 END IF
644 ENDDO
645 ENDDO
646C
647 RETURN
648 END
649C-----------Hybrid {x}t{y}-.{Weight}--
650!||====================================================================
651!|| sms_produt_h ../engine/source/ams/sms_proj.F
652!||--- called by ------------------------------------------------------
653!|| sms_mam_nm ../engine/source/ams/sms_proj.F
654!|| sms_mortho_gs ../engine/source/ams/sms_proj.f
655!||--- calls -----------------------------------------------------
656!|| my_barrier ../engine/source/system/machine.F
657!|| spmd_glob_dpsum9 ../engine/source/mpi/interfaces/spmd_th.F
658!|| spmd_rbcast ../engine/source/mpi/generic/spmd_rbcast.F
659!|| spmd_sum_s ../engine/source/mpi/implicit/imp_spmd.F
660!|| sum_6_float ../engine/source/system/parit.F
661!||====================================================================
662 SUBROUTINE sms_produt_h(NODFT ,NODLT ,X ,Y ,WEIGHT, R ,ITASK )
663C-----------------------------------------------
664C I m p l i c i t T y p e s
665C-----------------------------------------------
666#include "implicit_f.inc"
667#include "comlock.inc"
668C-----------------------------------------------
669C G l o b a l P a r a m e t e r s
670C-----------------------------------------------
671#include "mvsiz_p.inc"
672C-----------------------------------------------
673C C o m m o n B l o c k s
674C-----------------------------------------------
675#include "com01_c.inc"
676#include "parit_c.inc"
677#include "sms_c.inc"
678C-----------------------------------------------
679C D u m m y A r g u m e n t s
680C-----------------------------------------------
681 INTEGER NODFT ,NODLT ,WEIGHT(*) ,ITASK
682 my_real X(*), Y(*) ,R
683C-----------------------------------------------
684C L o c a l V a r i a b l e s
685C-----------------------------------------------
686 INTEGER I , N, J, K, L, LLT
687 my_real RTMP(MVSIZ), RL, RBUF
688 DOUBLE PRECISION R6T(6), DBUF(6)
689C-----------------------------
690 IF(IPARIT==0)then
691 IF (itask==0) r_n2_sms = zero
692C----------------------
693 CALL my_barrier
694C---------------------
695 rl = zero
696 DO n=nodft,nodlt,mvsiz
697 llt =min(nodlt-n+1,mvsiz)
698C
699 DO i=1,llt
700 j=n+i-1
701 rtmp(i)=x(j)*y(j)*weight(j)
702 ENDDO
703 DO i=1,llt
704 rl = rl + rtmp(i)
705 ENDDO
706 END DO
707#include "lockon.inc"
708 r_n2_sms = r_n2_sms + rl
709#include "lockoff.inc"
710C----------------------
711 CALL my_barrier
712C---------------------
713 IF (nspmd > 1 .AND. itask == 0) CALL spmd_sum_s(r_n2_sms)
714C----------------------
715 CALL my_barrier
716C---------------------
717 r = r_n2_sms
718 ELSE ! IPARIT/=0
719C
720 DO k=1,6
721 r6sms(k)=zero
722 ENDDO
723C----------------------
724 CALL my_barrier
725C---------------------
726 DO n=nodft,nodlt,mvsiz
727 llt =min(nodlt-n+1,mvsiz)
728C
729 DO i=1,llt
730 j=n+i-1
731 rtmp(i)=x(j)*y(j)*weight(j)
732 ENDDO
733 DO k=1,6
734 r6t(k) = zero
735 ENDDO
736 CALL sum_6_float(1,llt,rtmp,r6t,1)
737#include "lockon.inc"
738 DO k=1,6
739 r6sms(k)=r6sms(k)+r6t(k)
740 ENDDO
741#include "lockoff.inc"
742 END DO
743C----------------------
744 CALL my_barrier
745C---------------------
746 IF(nspmd <= 1)THEN
747 IF(itask==0)THEN
748 r_n2_sms=r6sms(1)+r6sms(2)+r6sms(3)+
749 . r6sms(4)+r6sms(5)+r6sms(6)
750 END IF
751 ELSEIF(itask==0)THEN
752 DO k=1,6
753 dbuf(k) =r6sms(k)
754 END DO
755 CALL spmd_glob_dpsum9(dbuf,6)
756 rbuf = dbuf(1)+dbuf(2)+dbuf(3)+
757 . dbuf(4)+dbuf(5)+dbuf(6)
758 CALL spmd_rbcast(rbuf,rbuf,1,1,0,2)
759 r_n2_sms=rbuf
760 END IF
761C----------------------
762 CALL my_barrier
763C---------------------
764 r = r_n2_sms
765 END IF
766C----------------------
767 CALL my_barrier
768C---------------------
769 RETURN
770 END
771C-----------Hybrid {x}t{y}-.{Weight}--
772!||====================================================================
773!|| sms_produt3 ../engine/source/ams/sms_proj.F
774!||--- called by ------------------------------------------------------
775!|| sms_mav_nm ../engine/source/ams/sms_proj.F
776!||--- calls -----------------------------------------------------
777!|| foat_to_6_float ../engine/source/system/parit.F
778!|| my_barrier ../engine/source/system/machine.F
779!|| spmd_glob_dpsum9 ../engine/source/mpi/interfaces/spmd_th.F
780!|| spmd_glob_dsum9 ../engine/source/mpi/interfaces/spmd_th.F
781!|| spmd_rbcast ../engine/source/mpi/generic/spmd_rbcast.F
782!||====================================================================
783 SUBROUTINE sms_produt3(NODFT ,NODLT ,X ,Y ,WEIGHT, R ,ITASK )
784C-----------------------------------------------
785C I m p l i c i t T y p e s
786C-----------------------------------------------
787#include "implicit_f.inc"
788#include "comlock.inc"
789C-----------------------------------------------
790C G l o b a l P a r a m e t e r s
791C-----------------------------------------------
792#include "mvsiz_p.inc"
793C-----------------------------------------------
794C C o m m o n B l o c k s
795C-----------------------------------------------
796#include "com01_c.inc"
797#include "parit_c.inc"
798#include "sms_c.inc"
799C-----------------------------------------------
800C D u m m y A r g u m e n t s
801C-----------------------------------------------
802 INTEGER NODFT ,NODLT ,WEIGHT(*) ,ITASK
803 my_real X(*), Y(3,*) ,R(3)
804C-----------------------------------------------
805C L o c a l V a r i a b l e s
806C-----------------------------------------------
807 INTEGER I , N, J, K, L, LLT
808 my_real
809 . RTMP(3,MVSIZ), RL(3), RBUF(3)
810 DOUBLE PRECISION R6(6,3,MVSIZ), R6T(3,6), DBUF(3,6)
811C-----------------------------
812 IF(IPARIT==0)then
813 IF (itask==0) THEN
814 r_n2_sms1 = zero
815 r_n2_sms2 = zero
816 r_n2_sms3 = zero
817 END IF
818C----------------------
819 CALL my_barrier
820C---------------------
821 rl(1:3) = zero
822 DO n=nodft,nodlt,mvsiz
823 llt =min(nodlt-n+1,mvsiz)
824C
825 DO i=1,llt
826 j=n+i-1
827 rtmp(1,i)=x(j)*y(1,j)*weight(j)
828 rtmp(2,i)=x(j)*y(2,j)*weight(j)
829 rtmp(3,i)=x(j)*y(3,j)*weight(j)
830 ENDDO
831 DO i=1,llt
832 rl(1) = rl(1) + rtmp(1,i)
833 rl(2) = rl(2) + rtmp(2,i)
834 rl(3) = rl(3) + rtmp(3,i)
835 ENDDO
836 END DO
837#include "lockon.inc"
838 r_n2_sms1 = r_n2_sms1 + rl(1)
839 r_n2_sms2 = r_n2_sms2 + rl(2)
840 r_n2_sms3 = r_n2_sms3 + rl(3)
841#include "lockoff.inc"
842C----------------------
843 CALL my_barrier
844C---------------------
845 IF (nspmd > 1 .AND. itask == 0) THEN
846 rbuf(1)=r_n2_sms1
847 rbuf(2)=r_n2_sms2
848 rbuf(3)=r_n2_sms3
849 CALL spmd_glob_dsum9(rbuf,3)
850 r_n2_sms1=rbuf(1)
851 r_n2_sms2=rbuf(2)
852 r_n2_sms3=rbuf(3)
853 END IF
854C----------------------
855 CALL my_barrier
856C---------------------
857 r(1) = r_n2_sms1
858 r(2) = r_n2_sms2
859 r(3) = r_n2_sms3
860 ELSE ! IPARIT/=0
861C
862 DO k=1,6
863 x6sms(1,k)=zero
864 x6sms(2,k)=zero
865 x6sms(3,k)=zero
866 ENDDO
867C----------------------
868 CALL my_barrier
869C---------------------
870 DO n=nodft,nodlt,mvsiz
871 llt =min(nodlt-n+1,mvsiz)
872C
873 DO i=1,llt
874 j=n+i-1
875 rtmp(1,i)=x(j)*y(1,j)*weight(j)
876 rtmp(2,i)=x(j)*y(2,j)*weight(j)
877 rtmp(3,i)=x(j)*y(3,j)*weight(j)
878 ENDDO
879 CALL foat_to_6_float(1,3*llt,rtmp,r6)
880 DO k=1,6
881 r6t(1,k) = zero
882 r6t(2,k) = zero
883 r6t(3,k) = zero
884 DO l=1,llt
885 r6t(1,k) = r6t(1,k) + r6(k,1,l)
886 r6t(2,k) = r6t(2,k) + r6(k,2,l)
887 r6t(3,k) = r6t(3,k) + r6(k,3,l)
888 ENDDO
889 ENDDO
890#include "lockon.inc"
891 DO k=1,6
892 x6sms(1,k)=x6sms(1,k)+r6t(1,k)
893 x6sms(2,k)=x6sms(2,k)+r6t(2,k)
894 x6sms(3,k)=x6sms(3,k)+r6t(3,k)
895 ENDDO
896#include "lockoff.inc"
897 END DO
898C----------------------
899 CALL my_barrier
900C---------------------
901 IF(nspmd <= 1)THEN
902 IF(itask==0)THEN
903 r_n2_sms1=x6sms(1,1)+x6sms(1,2)+x6sms(1,3)+
904 . x6sms(1,4)+x6sms(1,5)+x6sms(1,6)
905 r_n2_sms2=x6sms(2,1)+x6sms(2,2)+x6sms(2,3)+
906 . x6sms(2,4)+x6sms(2,5)+x6sms(2,6)
907 r_n2_sms3=x6sms(3,1)+x6sms(3,2)+x6sms(3,3)+
908 . x6sms(3,4)+x6sms(3,5)+x6sms(3,6)
909 END IF
910 ELSEIF(itask==0)THEN
911 DO k=1,6
912 dbuf(1,k) =x6sms(1,k)
913 dbuf(2,k) =x6sms(2,k)
914 dbuf(3,k) =x6sms(3,k)
915 END DO
916 CALL spmd_glob_dpsum9(dbuf,18)
917 rbuf(1) = dbuf(1,1)+dbuf(1,2)+dbuf(1,3)+
918 . dbuf(1,4)+dbuf(1,5)+dbuf(1,6)
919 rbuf(2) = dbuf(2,1)+dbuf(2,2)+dbuf(2,3)+
920 . dbuf(2,4)+dbuf(2,5)+dbuf(2,6)
921 rbuf(3) = dbuf(3,1)+dbuf(3,2)+dbuf(3,3)+
922 . dbuf(3,4)+dbuf(3,5)+dbuf(3,6)
923 CALL spmd_rbcast(rbuf,rbuf,3,1,0,2)
924 r_n2_sms1=rbuf(1)
925 r_n2_sms2=rbuf(2)
926 r_n2_sms3=rbuf(3)
927 END IF
928C----------------------
929 CALL my_barrier
930C---------------------
931 r(1) = r_n2_sms1
932 r(2) = r_n2_sms2
933 r(3) = r_n2_sms3
934 END IF
935C----------------------
936 CALL my_barrier
937C---------------------
938 RETURN
939 END
940!||====================================================================
941!|| sms_mav_nm ../engine/source/ams/sms_proj.F
942!||--- called by ------------------------------------------------------
943!|| sms_inix ../engine/source/ams/sms_proj.F
944!|| sms_pro_p ../engine/source/ams/sms_proj.F
945!||--- calls -----------------------------------------------------
946!|| sms_produt3 ../engine/source/ams/sms_proj.f
947!||====================================================================
948 SUBROUTINE sms_mav_nm(NODFT ,NODLT ,NUMNOD,MD ,A ,
949 . B ,C ,WEIGHT,ITASK )
950C-----------------------------------------------
951C I m p l i c i t T y p e s
952C-----------------------------------------------
953#include "implicit_f.inc"
954C-----------------------------------------------
955C D u m m y A r g u m e n t s
956C-----------------------------------------------
957 INTEGER NODFT ,NODLT ,NUMNOD ,MD ,ITASK ,WEIGHT(*)
958 my_real a(numnod,*), b(3,*), c(3,*)
959C-----------------------------------------------
960c FUNCTION: product {C}=[A]^t{B}
961c
962c Note:
963c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
964c
965c TYPE NAME FUNCTION
966c I NUMNOD,MD - Matrix dimension 2D
967c I WEIGHT(*) - itag for each node of subdomains
968c I NODFT ,NODLT,ITASK - id in each ITASK:thread id (//)
969c I A(NUMNOD,MD),B(3,NUMNOD) - right-hand vector
970c O C(3,MD) - left-hand vector
971C-----------------------------------------------
972C L o c a l V a r i a b l e s
973C-----------------------------------------------
974 INTEGER I,J,K
975C-----------------------------
976 DO I=1,md
977 CALL sms_produt3(nodft ,nodlt ,a(1,i) ,b ,weight ,c(1,i),itask)
978 ENDDO
979C--------------------------------------------
980 RETURN
981 END
982!||====================================================================
983!|| sms_mam_nm ../engine/source/ams/sms_proj.F
984!||--- called by ------------------------------------------------------
985!|| sms_inist ../engine/source/ams/sms_proj.F
986!||--- calls -----------------------------------------------------
987!|| sms_produt_h ../engine/source/ams/sms_proj.F
988!||====================================================================
989 SUBROUTINE sms_mam_nm(NODFT ,NODLT ,NUMNOD, MD ,A ,
990 . B ,C ,WEIGHT,ITASK)
991C-----------------------------------------------
992C I m p l i c i t T y p e s
993C-----------------------------------------------
994#include "implicit_f.inc"
995C-----------------------------------------------
996C D u m m y A r g u m e n t s
997C-----------------------------------------------
998 INTEGER NODFT ,NODLT ,NUMNOD,MD ,ITASK,WEIGHT(*)
999 my_real a(numnod,*), b(numnod,*), c(md,*)
1000C-----------------------------------------------
1001c FUNCTION: product {C}=[A]^t[B]
1002c
1003c Note:
1004c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
1005c
1006c TYPE NAME FUNCTION
1007c I NUMNOD,MD - Matrix dimension 2D
1008c I WEIGHT(*) - itag for each node of subdomains
1009c I NODFT ,NODLT,ITASK- id in each ITASK:thread id (//)
1010c I B(3,NUMNOD,MD) - right-hand Matrix
1011c O C(NM,MD) - left-hand vector
1012C-----------------------------------------------
1013C L o c a l V a r i a b l e s
1014C-----------------------------------------------
1015 INTEGER I,J,K
1016C-----------------------------
1017 DO I=1,md
1018 DO j=1,md
1019 CALL sms_produt_h( nodft ,nodlt ,a(1,i) ,b(1,j) ,weight,
1020 . c(i,j),itask)
1021 ENDDO
1022 ENDDO
1023C--------------------------------------------
1024 RETURN
1025 END
1026!||====================================================================
1027!|| sms_mortho_gs ../engine/source/ams/sms_proj.F
1028!||--- called by ------------------------------------------------------
1029!|| sms_inisi ../engine/source/ams/sms_proj.F
1030!||--- calls -----------------------------------------------------
1031!|| my_barrier ../engine/source/system/machine.F
1032!|| sms_produt_h ../engine/source/ams/sms_proj.F
1033!|| vaxpy_h ../engine/source/implicit/produt_v.F
1034!|| vscal_h ../engine/source/implicit/produt_v.F
1035!||====================================================================
1036 SUBROUTINE sms_mortho_gs(NODFT ,NODLT ,NUMNOD ,MD_F ,MD_L ,
1037 . A ,WEIGHT ,ITASK )
1038C-----------------------------------------------
1039C I m p l i c i t T y p e s
1040C-----------------------------------------------
1041#include "implicit_f.inc"
1042C-----------------------------------------------
1043C D u m m y A r g u m e n t s
1044C-----------------------------------------------
1045 INTEGER NUMNOD ,MD_F,MD_L,NODFT ,NODLT ,WEIGHT(*), ITASK
1046 my_real A(NUMNOD,*)
1047C-----------------------------------------------
1048c FUNCTION: stabilized Gram-Schmidt orthonormalization (from MD_F to MD_L)
1049c
1050c Note:
1051c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
1052c
1053c TYPE NAME FUNCTION
1054c I MD_F to MD_L - vectors to be orthonormalized dim. of A(*,MD) should be MD_L
1055c I WEIGHT(*) - itag for each node with subdomains
1056c IO A(NUMNOD,MD) - A(NDDL,MD) orthonormalized for output
1057C-----------------------------------------------
1058C L o c a l V a r i a b l e s
1059C-----------------------------------------------
1060 INTEGER I,J,F_DDL,L_DDL
1061 my_real
1062 . sii,sij,s,sjj
1063C-----------------------------
1064 DO j= md_f ,md_l
1065 DO i=1,j-1
1066 CALL sms_produt_h(nodft ,nodlt ,a(1,i) ,a(1,j) ,weight,
1067 . sij ,itask)
1068 s = -sij
1069 CALL vaxpy_h(nodft ,nodlt ,a(1,i) ,a(1,j) ,s ,itask )
1070C----------------------
1071 CALL my_barrier
1072C---------------------
1073 END DO
1074 CALL sms_produt_h(nodft ,nodlt ,a(1,j) ,a(1,j) ,weight,
1075 . sjj ,itask)
1076 s= one/max(em20,sqrt(sjj))
1077 CALL vscal_h(nodft ,nodlt ,a(1,j) ,s ,itask )
1078C----------------------
1079 CALL my_barrier
1080C---------------------
1081 END DO
1082C--------------------------------------------
1083 RETURN
1084 END
1085!||====================================================================
1086!|| sms_mav_mn ../engine/source/ams/sms_proj.F
1087!||--- called by ------------------------------------------------------
1088!|| sms_inix ../engine/source/ams/sms_proj.F
1089!|| sms_pro_p ../engine/source/ams/sms_proj.F
1090!||--- calls -----------------------------------------------------
1091!|| sms_produt_v_loc ../engine/source/ams/sms_proj.F
1092!||====================================================================
1093 SUBROUTINE sms_mav_mn(ND ,MD ,A ,B ,C ,ITASK )
1094C-----------------------------------------------
1095C I m p l i c i t T y p e s
1096C-----------------------------------------------
1097#include "implicit_f.inc"
1098C-----------------------------------------------
1099C D u m m y A r g u m e n t s
1100C-----------------------------------------------
1101 INTEGER ND ,MD ,ITASK
1102 my_real a(nd,*), b(3,*), c(3,*)
1103C-----------------------------------------------
1104c FUNCTION: product {C}=[A]{B}
1105c
1106c Note:
1107c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
1108c
1109c TYPE NAME FUNCTION
1110c I ND,MN - Matrix dimension 2D
1111c I ITASK - thread id (//)
1112c I B(3,NM) - right-hand vector
1113c O C(3,ND) - left-hand vector
1114C-----------------------------------------------
1115C L o c a l V a r i a b l e s
1116C-----------------------------------------------
1117 INTEGER I,J,K
1118 my_real
1119 . w(md)
1120C-----------------------------
1121 IF (itask /= 0) RETURN
1122C------------may add dynamic smp on ND after--
1123 DO i=1,nd
1124 DO j= 1,md
1125 w(j)= a(i,j)
1126 END DO
1127 CALL sms_produt_v_loc( md ,w ,b ,c(1,i))
1128 ENDDO
1129C--------------------------------------------
1130 RETURN
1131 END
1132C---------------------r={x}^t{y}---
1133!||====================================================================
1134!|| sms_produt_v_loc ../engine/source/ams/sms_proj.F
1135!||--- called by ------------------------------------------------------
1136!|| sms_mav_mn ../engine/source/ams/sms_proj.F
1137!||====================================================================
1138 SUBROUTINE sms_produt_v_loc( NDDL ,X ,Y ,R)
1139C-----------------------------------------------
1140C I m p l i c i t T y p e s
1141C-----------------------------------------------
1142#include "implicit_f.inc"
1143C-----------------------------------------------
1144C D u m m y A r g u m e n t s
1145C-----------------------------------------------
1146 INTEGER NDDL
1147 my_real x(*), y(3,*) ,r(3)
1148C-----------------------------------------------
1149C L o c a l V a r i a b l e s
1150C-----------------------------------------------
1151 INTEGER I
1152C-----------------------------
1153 r(1) = zero
1154 r(2) = zero
1155 r(3) = zero
1156 DO i=1,nddl
1157 r(1) = r(1) + x(i)*y(1,i)
1158 r(2) = r(2) + x(i)*y(2,i)
1159 r(3) = r(3) + x(i)*y(3,i)
1160 ENDDO
1161C--------------------------------------------
1162 RETURN
1163 END
my_real
#define my_real
Definition cppsort.cpp:32
dsyev
subroutine dsyev(jobz, uplo, n, a, lda, w, work, lwork, info)
DSYEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices
Definition dsyev.f:132
ssyev
subroutine ssyev(jobz, uplo, n, a, lda, w, work, lwork, info)
SSYEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices
Definition ssyev.f:132
spmd_sum_s
subroutine spmd_sum_s(s)
Definition imp_spmd.F:1037
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
sms_pcg_proj
Definition sms_mod.F:72
sum_6_float
subroutine sum_6_float(jft, jlt, f, f6, n)
Definition parit.F:64
foat_to_6_float
subroutine foat_to_6_float(jft, jlt, f, f6)
Definition parit.F:225
vscal_h
subroutine vscal_h(f_ddl, l_ddl, v, s, itask)
Definition produt_v.F:2609
mav_mm
subroutine mav_mm(nd, md, a, b, itask)
Definition produt_v.F:2883
vaxpy_h
subroutine vaxpy_h(f_ddl, l_ddl, a, b, s, itask)
Definition produt_v.F:2647
sms_mav_lt2
subroutine sms_mav_lt2(timers, nodft, nodlt, numnod, iadl, jdil, itask, diag_k, lt_k, v, w, nodft1_sms, nodlt1_sms, indx1_sms, nodnx_sms, iad_elem, fr_elem, weight, jadi_sms, jdii_sms, lti_sms, iskyi_sms, mskyi_sms, fr_sms, fr_rms, list_sms, list_rms, mskyi_fi_sms, vfi, imv, mv, mv6, mw6)
Definition sms_pcg.F:2531
sms_mortho_gs
subroutine sms_mortho_gs(nodft, nodlt, numnod, md_f, md_l, a, weight, itask)
Definition sms_proj.F:1038
sms_mav_nm
subroutine sms_mav_nm(nodft, nodlt, numnod, md, a, b, c, weight, itask)
Definition sms_proj.F:950
sms_mam_nm
subroutine sms_mam_nm(nodft, nodlt, numnod, md, a, b, c, weight, itask)
Definition sms_proj.F:991
sms_produt_h
subroutine sms_produt_h(nodft, nodlt, x, y, weight, r, itask)
Definition sms_proj.F:663
sms_inist
subroutine sms_inist(timers, iadk, jdik, diag_k, lt_k, itask, nodft1_sms, nodlt1_sms, indx1_sms, nodnx_sms, iad_elem, fr_elem, weight, jadi_sms, jdii_sms, lti_sms, iskyi_sms, mskyi_sms, fr_sms, fr_rms, list_sms, list_rms, mskyi_fi_sms, vfi, imv, mv, mv6, mw6, ms, nodft, nodlt)
Definition sms_proj.F:45
sms_produt3
subroutine sms_produt3(nodft, nodlt, x, y, weight, r, itask)
Definition sms_proj.F:784
sms_inisi
subroutine sms_inisi(iadk, jdik, diag_k, lt_k, itask, nodft1_sms, nodlt1_sms, indx1_sms, nodnx_sms, iad_elem, fr_elem, weight, jadi_sms, jdii_sms, lti_sms, iskyi_sms, mskyi_sms, fr_sms, fr_rms, list_sms, list_rms, mskyi_fi_sms, vfi, imv, mv, mv6, mw6, ms, nodft, nodlt, prec_sms, kinet)
Definition sms_proj.F:507
sms_mav_mn
subroutine sms_mav_mn(nd, md, a, b, c, itask)
Definition sms_proj.F:1094
sms_pro_p
subroutine sms_pro_p(timers, nodft, nodlt, numnod, p, weight, itask, pj, diag_sms)
Definition sms_proj.F:302
sms_produt_v_loc
subroutine sms_produt_v_loc(nddl, x, y, r)
Definition sms_proj.F:1139
sms_updst
subroutine sms_updst(iadk, jdik, diag_k, lt_k, itask, nodft1_sms, nodlt1_sms, indx1_sms, nodnx_sms, iad_elem, fr_elem, weight, jadi_sms, jdii_sms, lti_sms, iskyi_sms, mskyi_sms, fr_sms, fr_rms, list_sms, list_rms, mskyi_fi_sms, vfi, imv, mv, mv6, mw6, ms, u, p, y, nodft, nodlt, kinet)
Definition sms_proj.F:416
sms_inix
subroutine sms_inix(timers, nodft, nodlt, numnod, x, r, weight, itask, diag_sms)
Definition sms_proj.F:184
sms_inis
subroutine sms_inis(numnod, nodft, nodlt, npf, npl, s, nodnx_sms, kinet)
Definition sms_proj.F:608
spmd_exch_sms
subroutine spmd_exch_sms(v, nodnx_sms, iad_elem, fr_elem, size, lenr)
Definition spmd_exch_sms.F:36
spmd_rbcast
subroutine spmd_rbcast(tabi, tabr, n1, n2, from, add)
Definition spmd_rbcast.F:62
spmd_glob_dsum9
subroutine spmd_glob_dsum9(v, len)
Definition spmd_th.F:380
spmd_glob_dpsum9
subroutine spmd_glob_dpsum9(v, len)
Definition spmd_th.F:437
my_barrier
subroutine my_barrier
Definition machine.F:31
startime
subroutine startime(event, itask)
Definition timer.F:93
stoptime
subroutine stoptime(event, itask)
Definition timer.F:135