OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
sarrowheads.F File Reference

Go to the source code of this file.

Functions/Subroutines

subroutine smumps_ana_dist_arrowheads (myid, slavef, n, procnode, step, ptraiw, ptrarw, istep_to_iniv2, i_am_cand, keep, keep8, icntl, id)
subroutine smumps_facto_send_arrowheads (n, nz, aspk, irn, icn, perm, lscal, colsca, rowsca, myid, slavef, procnode_steps, nbrecords, lp, comm, root, keep, keep8, fils, rg2l, intarr, lintarr, dblarr, ldblarr, ptraiw, ptrarw, frere_steps, step, a, la, istep_to_iniv2, i_am_cand, candidates)
subroutine smumps_arrow_fill_send_buf ()
subroutine smumps_arrow_fill_send_buf_elt (isend_shr, jsend_shr, val_shr, dest_shr, bufi, bufr, nbrecords, nbufs, lp, comm)
subroutine smumps_arrow_finish_send_buf (bufi, bufr, nbrecords, nbufs, lp, comm, type_parall)
recursive subroutine smumps_quick_sort_arrowheads (n, perm, intlist, dbllist, taille, lo, hi)
subroutine smumps_facto_recv_arrowhd2 (n, dblarr, ldblarr, intarr, lintarr, ptraiw, ptrarw, keep, keep8, myid, comm, nbrecords, a, la, root, procnode_steps, slavef, perm, frere_steps, step, info1, info2)
subroutine smumps_set_to_zero (a, lld, m, n, keep)
subroutine smumps_set_root_to_zero (root, keep, a, la)
subroutine smumps_get_root_info (root, local_m, local_n, ptr_root, la)

Function/Subroutine Documentation

◆ smumps_ana_dist_arrowheads()

subroutine smumps_ana_dist_arrowheads ( integer myid,
integer slavef,
integer n,
integer, dimension( keep(28) ) procnode,
integer, dimension( n ) step,
integer(8), dimension( n ), intent(inout) ptraiw,
integer(8), dimension( n ), intent(inout) ptrarw,
integer, dimension(keep(71)) istep_to_iniv2,
logical, dimension(max(1,keep(56))) i_am_cand,
integer, dimension( 500 ) keep,
integer(8), dimension(150) keep8,
integer, dimension( 60 ) icntl,
type (smumps_struc) id )

Definition at line 14 of file sarrowheads.F.

18 USE smumps_struc_def
19 IMPLICIT NONE
20 TYPE (SMUMPS_STRUC) :: id
21 INTEGER MYID, N, SLAVEF
22 INTEGER KEEP( 500 ), ICNTL( 60 )
23 INTEGER(8) KEEP8(150)
24 INTEGER PROCNODE( KEEP(28) ), STEP( N )
25 INTEGER(8), INTENT(INOUT) :: PTRAIW( N ), PTRARW( N )
26 INTEGER ISTEP_TO_INIV2(KEEP(71))
27 LOGICAL I_AM_CAND(max(1,KEEP(56)))
28 LOGICAL I_AM_SLAVE
29 LOGICAL I_AM_CAND_LOC
30 INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE, MUMPS_TYPESPLIT
31 EXTERNAL mumps_typenode, mumps_procnode, mumps_typesplit
32 INTEGER ISTEP, I, NCOL, NROW, allocok
33 INTEGER TYPE_PARALL, ITYPE, IRANK, INIV2, TYPESPLIT
34 LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS
35 INTEGER(8) :: IPTRI, IPTRR
36 earlyt3rootins = keep(200) .EQ. 0
37 & .OR. (keep(200) .LT. 0 .AND. keep(400) .EQ. 0)
38 type_parall = keep(46)
39 i_am_slave = (keep(46).EQ.1 .OR. myid.NE.0)
40 keep8(26) = 0_8
41 keep8(27) = 0_8
42 DO i = 1, n
43 istep=abs(step(i))
44 itype = mumps_typenode( procnode(istep), keep(199) )
45 irank = mumps_procnode( procnode(istep), keep(199) )
46 i_am_cand_loc = .false.
47 typesplit = mumps_typesplit( procnode(istep), keep(199) )
48 t4_master_concerned = .false.
49 IF (itype.EQ.2) THEN
50 iniv2 = istep_to_iniv2(istep)
51 IF (i_am_slave) THEN
52 i_am_cand_loc = i_am_cand(iniv2)
53 IF ( (typesplit.EQ.5).OR.(typesplit.EQ.6)) THEN
54 IF ( type_parall .eq. 0 ) THEN
55 t4_master_concerned =
56 & ( id%CANDIDATES (id%CANDIDATES(slavef+1,iniv2)+1,iniv2)
57 & .EQ.myid-1 )
58 ELSE
59 t4_master_concerned =
60 & ( id%CANDIDATES (id%CANDIDATES(slavef+1, iniv2)+1,iniv2 )
61 & .EQ.myid )
62 ENDIF
63 ENDIF
64 ENDIF
65 ENDIF
66 IF ( type_parall .eq. 0 ) THEN
67 irank = irank + 1
68 END IF
69 IF (
70 & ( (itype .EQ. 1.OR.itype.EQ.2) .AND.
71 & irank .EQ. myid )
72 & .OR.
73 & ( t4_master_concerned )
74 & ) THEN
75 keep8(26) = keep8(26) + 1_8 + ptraiw(i)+ptrarw(i)
76 keep8(27) = keep8(27) + 3_8 + ptraiw(i)+ptrarw(i)
77 ELSE IF ( itype .EQ. 3 ) THEN
78 IF (earlyt3rootins) THEN
79 ELSE
80 keep8(26) = keep8(26) + 1_8 + ptraiw(i)+ptrarw(i)
81 keep8(27) = keep8(27) + 3_8 + ptraiw(i)+ptrarw(i)
82 ENDIF
83 ELSE IF ( itype .EQ. 2 .AND. i_am_cand_loc ) THEN
84 ptrarw( i ) = 0_8
85 keep8(26) = keep8(26) + 1_8 + ptraiw(i)+ptrarw(i)
86 keep8(27) = keep8(27) + 3_8 + ptraiw(i)+ptrarw(i)
87 END IF
88 END DO
89 IF ( associated( id%INTARR ) ) THEN
90 DEALLOCATE( id%INTARR )
91 NULLIFY( id%INTARR )
92 END IF
93 IF ( keep8(27) > 0 ) THEN
94 ALLOCATE( id%INTARR( keep8(27) ), stat = allocok )
95 IF ( allocok .GT. 0 ) THEN
96 id%INFO(1) = -7
97 CALL mumps_set_ierror(keep8(27),id%INFO(2))
98 RETURN
99 END IF
100 ELSE
101 ALLOCATE( id%INTARR( 1 ), stat = allocok )
102 IF ( allocok .GT. 0 ) THEN
103 id%INFO(1) = -7
104 id%INFO(2) = 1
105 RETURN
106 END IF
107 END IF
108 iptri = 1_8
109 iptrr = 1_8
110 DO i = 1, n
111 istep = abs(step(i))
112 itype = mumps_typenode( procnode(istep), keep(199) )
113 irank = mumps_procnode( procnode(istep), keep(199) )
114 typesplit = mumps_typesplit( procnode(istep), keep(199) )
115 i_am_cand_loc = .false.
116 t4_master_concerned = .false.
117 IF (itype.EQ.2) THEN
118 iniv2 = istep_to_iniv2(istep)
119 IF (i_am_slave) THEN
120 i_am_cand_loc = i_am_cand(iniv2)
121 IF ( (typesplit.EQ.5).OR.(typesplit.EQ.6)) THEN
122 IF ( type_parall .eq. 0 ) THEN
123 t4_master_concerned =
124 & (id%CANDIDATES (id%CANDIDATES(slavef+1,iniv2)+1,iniv2)
125 & .EQ.myid-1 )
126 ELSE
127 t4_master_concerned =
128 & (id%CANDIDATES (id%CANDIDATES(slavef+1,iniv2)+1,iniv2)
129 & .EQ.myid )
130 ENDIF
131 ENDIF
132 ENDIF
133 ENDIF
134 IF ( type_parall .eq. 0 ) THEN
135 irank =irank + 1
136 END IF
137 IF (
138 & ( itype .eq. 2 .and.
139 & irank .eq. myid )
140 & .or.
141 & ( itype .eq. 1 .and.
142 & irank .eq. myid )
143 & .or.
144 & ( t4_master_concerned )
145 & ) THEN
146 ncol = int(ptraiw( i ))
147 nrow = int(ptrarw( i ))
148 id%INTARR( iptri ) = ncol
149 id%INTARR( iptri + 1 ) = -nrow
150 id%INTARR( iptri + 2 ) = i
151 ptraiw( i ) = iptri
152 ptrarw( i ) = iptrr
153 iptri = iptri + int(ncol + nrow + 3,8)
154 iptrr = iptrr + int(ncol + nrow + 1,8)
155 ELSE IF ( itype .eq. 3) THEN
156 IF ( earlyt3rootins ) THEN
157 ptraiw(i)=0
158 ptrarw(i)=0
159 ELSE
160 ncol = int(ptraiw( i ))
161 nrow = int(ptrarw( i ))
162 id%INTARR( iptri ) = ncol
163 id%INTARR( iptri + 1 ) = -nrow
164 id%INTARR( iptri + 2 ) = i
165 ptraiw( i ) = iptri
166 ptrarw( i ) = iptrr
167 iptri = iptri + int(ncol + nrow + 3,8)
168 iptrr = iptrr + int(ncol + nrow + 1,8)
169 ENDIF
170 ELSE IF ( itype .eq. 2 .AND. i_am_cand_loc ) THEN
171 ncol = int(ptraiw( i ))
172 nrow = 0
173 id%INTARR( iptri ) = ncol
174 id%INTARR( iptri + 1 ) = -nrow
175 id%INTARR( iptri + 2 ) = i
176 ptraiw( i ) = iptri
177 ptrarw( i ) = iptrr
178 iptri = iptri + int(ncol + nrow + 3, 8)
179 iptrr = iptrr + int(ncol + nrow + 1, 8)
180 ELSE
181 ptraiw(i) = 0_8
182 ptrarw(i) = 0_8
183 END IF
184 END DO
185 IF ( iptri - 1_8 .NE. keep8(27) ) THEN
186 WRITE(*,*) 'Error 1 in ana_arrowheads',
187 & ' IPTRI - 1, KEEP8(27)=', iptri - 1, keep8(27)
188 CALL mumps_abort()
189 END IF
190 IF ( iptrr - 1_8 .NE. keep8(26) ) THEN
191 WRITE(*,*) 'Error 2 in ana_arrowheads'
192 CALL mumps_abort()
193 END IF
194 RETURN
mumps_abort
#define mumps_abort
Definition VE_Metis.h:25
id
initmumps id
Definition multiplerhs_example.m:4
smumps_struc_def
Definition smumps_struc_def.F:14
mumps_typenode
integer function mumps_typenode(procinfo_inode, k199)
Definition tools_common.F:90
mumps_procnode
integer function mumps_procnode(procinfo_inode, k199)
Definition tools_common.F:151
mumps_set_ierror
subroutine mumps_set_ierror(size8, ierror)
Definition tools_common.F:865
mumps_typesplit
integer function mumps_typesplit(procinfo_inode, k199)
Definition tools_common.F:171

◆ smumps_arrow_fill_send_buf()

subroutine smumps_facto_send_arrowheads::smumps_arrow_fill_send_buf

Definition at line 601 of file sarrowheads.F.

602 IMPLICIT NONE
603 include 'mpif.h'
604 include 'mumps_tags.h'
605 INTEGER IERR
606 INTEGER TAILLE_SENDI, TAILLE_SENDR, IREQ
607 IF (bufi(1,dest_shr)+1.GT.nbrecords) THEN
608 taille_sendi = bufi(1,dest_shr) * 2 + 1
609 taille_sendr = bufi(1,dest_shr)
610 CALL mpi_send(bufi(1,dest_shr),taille_sendi,
611 & mpi_integer,
612 & dest_shr, arrowhead, comm, ierr )
613 CALL mpi_send( bufr(1,dest_shr), taille_sendr,
614 & mpi_real, dest_shr,
615 & arrowhead, comm, ierr )
616 bufi(1,dest_shr) = 0
617 ENDIF
618 ireq = bufi(1,dest_shr) + 1
619 bufi(1,dest_shr) = ireq
620 bufi( ireq * 2, dest_shr ) = isend_shr
621 bufi( ireq * 2 + 1, dest_shr ) = jsend_shr
622 bufr( ireq, dest_shr ) = val_shr
623 RETURN
mpi_send
subroutine mpi_send(buf, cnt, datatype, dest, tag, comm, ierr)
Definition mpi.f:480

◆ smumps_arrow_fill_send_buf_elt()

subroutine smumps_arrow_fill_send_buf_elt ( integer, intent(in) isend_shr,
integer, intent(in) jsend_shr,
real, intent(in) val_shr,
integer dest_shr,
integer, dimension( nbrecords*2+1, nbufs ) bufi,
real, dimension( nbrecords, nbufs ) bufr,
integer nbrecords,
integer nbufs,
integer lp,
integer comm )

Definition at line 626 of file sarrowheads.F.

629 IMPLICIT NONE
630 INTEGER, INTENT(in) :: ISEND_SHR, JSEND_SHR
631 REAL, INTENT(in) :: VAL_SHR
632 INTEGER :: DEST_SHR, NBRECORDS, NBUFS, LP, COMM
633 INTEGER :: BUFI( NBRECORDS*2+1, NBUFS )
634 REAL :: BUFR( NBRECORDS, NBUFS )
635 include 'mpif.h'
636 include 'mumps_tags.h'
637 INTEGER IERR
638 INTEGER TAILLE_SENDI, TAILLE_SENDR, IREQ
639 IF (bufi(1,dest_shr)+1.GT.nbrecords) THEN
640 taille_sendi = bufi(1,dest_shr) * 2 + 1
641 taille_sendr = bufi(1,dest_shr)
642 CALL mpi_send(bufi(1,dest_shr),taille_sendi,
643 & mpi_integer,
644 & dest_shr, arrowhead, comm, ierr )
645 CALL mpi_send( bufr(1,dest_shr), taille_sendr,
646 & mpi_real, dest_shr,
647 & arrowhead, comm, ierr )
648 bufi(1,dest_shr) = 0
649 ENDIF
650 ireq = bufi(1,dest_shr) + 1
651 bufi(1,dest_shr) = ireq
652 bufi( ireq * 2, dest_shr ) = isend_shr
653 bufi( ireq * 2 + 1, dest_shr ) = jsend_shr
654 bufr( ireq, dest_shr ) = val_shr
655 RETURN

◆ smumps_arrow_finish_send_buf()

subroutine smumps_arrow_finish_send_buf ( integer, dimension( nbrecords * 2 + 1, nbufs ) bufi,
real, dimension( nbrecords, nbufs ) bufr,
integer nbrecords,
integer nbufs,
integer lp,
integer comm,
integer type_parall )

Definition at line 657 of file sarrowheads.F.

660 IMPLICIT NONE
661 INTEGER NBUFS, NBRECORDS, TYPE_PARALL
662 INTEGER BUFI( NBRECORDS * 2 + 1, NBUFS )
663 REAL BUFR( NBRECORDS, NBUFS )
664 INTEGER COMM
665 INTEGER LP
666 INTEGER ISLAVE, TAILLE_SENDI, TAILLE_SENDR, IERR
667 include 'mpif.h'
668 include 'mumps_tags.h'
669 DO islave = 1,nbufs
670 taille_sendi = bufi(1,islave) * 2 + 1
671 taille_sendr = bufi(1,islave)
672 bufi(1,islave) = - bufi(1,islave)
673 CALL mpi_send(bufi(1,islave),taille_sendi,
674 & mpi_integer,
675 & islave, arrowhead, comm, ierr )
676 IF ( taille_sendr .NE. 0 ) THEN
677 CALL mpi_send( bufr(1,islave), taille_sendr,
678 & mpi_real, islave,
679 & arrowhead, comm, ierr )
680 END IF
681 ENDDO
682 RETURN

◆ smumps_facto_recv_arrowhd2()

subroutine smumps_facto_recv_arrowhd2 ( integer n,
real, dimension(ldblarr) dblarr,
integer(8), intent(in) ldblarr,
integer, dimension(lintarr) intarr,
integer(8), intent(in) lintarr,
integer(8), dimension(n), intent(in) ptraiw,
integer(8), dimension(n), intent(in) ptrarw,
integer, dimension(500) keep,
integer(8), dimension(150) keep8,
integer myid,
integer comm,
integer nbrecords,
real, dimension( la ) a,
integer(8), intent(in) la,
type (smumps_root_struc) root,
integer, dimension( keep(28) ) procnode_steps,
integer slavef,
integer, dimension( n ) perm,
integer, dimension( keep(28) ) frere_steps,
integer, dimension(n) step,
integer info1,
integer info2 )

Definition at line 725 of file sarrowheads.F.

732 USE smumps_struc_def, ONLY : smumps_root_struc
733 IMPLICIT NONE
734 INTEGER N, MYID, COMM
735 INTEGER(8), INTENT(IN) :: LDBLARR, LINTARR
736 INTEGER INTARR(LINTARR)
737 INTEGER(8), INTENT(IN) :: PTRAIW(N), PTRARW(N)
738 INTEGER KEEP(500)
739 INTEGER(8) KEEP8(150)
740 INTEGER(8), intent(IN) :: LA
741 INTEGER PROCNODE_STEPS( KEEP(28) ), PERM( N )
742 INTEGER SLAVEF, NBRECORDS
743 REAL A( LA )
744 INTEGER INFO1, INFO2
745 REAL DBLARR(LDBLARR)
746 INTEGER FRERE_STEPS( KEEP(28) ), STEP(N)
747 TYPE (SMUMPS_ROOT_STRUC) :: root
748 INTEGER, POINTER, DIMENSION(:) :: BUFI
749 REAL, POINTER, DIMENSION(:) :: BUFR
750 INTEGER, POINTER, DIMENSION(:,:) :: IW4
751 LOGICAL :: EARLYT3ROOTINS
752 LOGICAL FINI
753 INTEGER IREC, NB_REC, IARR, JARR, I, allocok
754 INTEGER(8) :: I18, IA8, IS18, IIW8, IS8, IAS8
755 INTEGER ISHIFT
756 INTEGER LOCAL_M, LOCAL_N, ILOCROOT, JLOCROOT,
757 & IPOSROOT, JPOSROOT, TAILLE,
758 & IPROC
759 INTEGER(8) :: PTR_ROOT
760 INTEGER ARROW_ROOT, TYPE_PARALL
761 INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE
762 EXTERNAL mumps_typenode, mumps_procnode
763 REAL VAL
764 REAL ZERO
765 parameter( zero = 0.0e0 )
766 include 'mpif.h'
767 include 'mumps_tags.h'
768 INTEGER MASTER
769 parameter(master=0)
770 INTEGER :: IERR
771 INTEGER :: STATUS(MPI_STATUS_SIZE)
772 INTEGER numroc
773 EXTERNAL numroc
774 type_parall = keep(46)
775 arrow_root=0
776 earlyt3rootins = keep(200) .EQ. 0
777 & .OR. (keep(200) .LT. 0 .AND. keep(400) .EQ. 0)
778 ALLOCATE( bufi( nbrecords * 2 + 1 ), stat = allocok )
779 IF ( allocok .GT. 0 ) THEN
780 info1 = -13
781 info2 = nbrecords * 2 + 1
782 WRITE(*,*) myid,': Could not allocate BUFI: goto 500'
783 GOTO 500
784 END IF
785 ALLOCATE( bufr( nbrecords ) , stat = allocok )
786 IF ( allocok .GT. 0 ) THEN
787 info1 = -13
788 info2 = nbrecords
789 WRITE(*,*) myid,': Could not allocate BUFR: goto 500'
790 GOTO 500
791 END IF
792 ALLOCATE( iw4(n,2), stat = allocok )
793 IF ( allocok .GT. 0 ) THEN
794 info1 = -13
795 info2 = 2 * n
796 WRITE(*,*) myid,': Could not allocate IW4: goto 500'
797 GOTO 500
798 END IF
799 IF ( keep(38).NE.0 .AND. earlyt3rootins ) THEN
800 CALL smumps_get_root_info(root, local_m, local_n, ptr_root, la)
801 CALL smumps_set_root_to_zero(root, keep, a, la)
802 ELSE
803 local_m = -19999; local_n = -29999; ptr_root = -99999_8
804 END IF
805 fini = .false.
806#if defined(__ve__)
807!NEC$ IVDEP
808#endif
809 DO i=1,n
810 i18 = ptraiw(i)
811 ia8 = ptrarw(i)
812 IF (ia8.GT.0_8) THEN
813 dblarr(ia8) = zero
814 iw4(i,1) = intarr(i18)
815 iw4(i,2) = -intarr(i18+1_8)
816 intarr(i18+2)=i
817 ENDIF
818 ENDDO
819 DO WHILE (.NOT.fini)
820 CALL mpi_recv( bufi(1), 2*nbrecords+1,
821 & mpi_integer, master,
822 & arrowhead,
823 & comm, status, ierr )
824 nb_rec = bufi(1)
825 IF (nb_rec.LE.0) THEN
826 fini = .true.
827 nb_rec = -nb_rec
828 ENDIF
829 IF (nb_rec.EQ.0) EXIT
830 CALL mpi_recv( bufr(1), nbrecords, mpi_real,
831 & master, arrowhead,
832 & comm, status, ierr )
833 DO irec=1, nb_rec
834 iarr = bufi( irec * 2 )
835 jarr = bufi( irec * 2 + 1 )
836 val = bufr( irec )
837 IF ( mumps_typenode( procnode_steps(abs(step(abs(iarr)))),
838 & keep(199) ) .eq. 3
839 & .AND. earlyt3rootins ) THEN
840 IF ( iarr .GT. 0 ) THEN
841 iposroot = root%RG2L_ROW( iarr )
842 jposroot = root%RG2L_COL( jarr )
843 ELSE
844 iposroot = root%RG2L_ROW( jarr )
845 jposroot = root%RG2L_COL( -iarr )
846 END IF
847 ilocroot = root%MBLOCK * ( ( iposroot - 1 ) /
848 & ( root%MBLOCK * root%NPROW ) )
849 & + mod( iposroot - 1, root%MBLOCK ) + 1
850 jlocroot = root%NBLOCK * ( ( jposroot - 1 ) /
851 & ( root%NBLOCK * root%NPCOL ) )
852 & + mod( jposroot - 1, root%NBLOCK ) + 1
853 IF (keep(60)==0) THEN
854 a( ptr_root + int(jlocroot - 1,8) * int(local_m,8)
855 & + int(ilocroot - 1,8) )
856 & = a( ptr_root + int(jlocroot - 1,8)
857 & * int(local_m,8)
858 & + int(ilocroot - 1,8))
859 & + val
860 ELSE
861 root%SCHUR_POINTER( int(jlocroot-1,8)
862 & * int(root%SCHUR_LLD,8)
863 & + int(ilocroot,8) )
864 & = root%SCHUR_POINTER( int(jlocroot - 1,8)
865 & * int(root%SCHUR_LLD,8)
866 & + int(ilocroot,8))
867 & + val
868 ENDIF
869 ELSE IF (iarr.GE.0) THEN
870 IF (iarr.EQ.jarr) THEN
871 ia8 = ptrarw(iarr)
872 dblarr(ia8) = dblarr(ia8) + val
873 ELSE
874 is18 = ptraiw(iarr)
875 ishift = intarr(is18) + iw4(iarr,2)
876 iw4(iarr,2) = iw4(iarr,2) - 1
877 iiw8 = is18 + ishift + 2
878 intarr(iiw8) = jarr
879 is8 = ptrarw(iarr)
880 ias8 = is8 + ishift
881 dblarr(ias8) = val
882 ENDIF
883 ELSE
884 iarr = -iarr
885 is8 = ptraiw(iarr)+iw4(iarr,1)+2
886 intarr(is8) = jarr
887 ias8 = ptrarw(iarr)+iw4(iarr,1)
888 iw4(iarr,1) = iw4(iarr,1) - 1
889 dblarr(ias8) = val
890 IF ( iw4(iarr,1) .EQ. 0
891 & .AND. step(iarr) > 0 ) THEN
892 iproc = mumps_procnode( procnode_steps(step(iarr)),
893 & keep(199) )
894 IF ( type_parall .eq. 0 ) THEN
895 iproc = iproc + 1
896 END IF
897 IF (iproc .EQ. myid) THEN
898 taille = intarr( ptraiw(iarr) )
899 CALL smumps_quick_sort_arrowheads( n, perm,
900 & intarr( ptraiw(iarr) + 3 ),
901 & dblarr( ptrarw(iarr) + 1 ),
902 & taille, 1, taille )
903 END IF
904 END IF
905 ENDIF
906 ENDDO
907 END DO
908 DEALLOCATE( bufi )
909 DEALLOCATE( bufr )
910 DEALLOCATE( iw4 )
911 500 CONTINUE
912 keep(49) = arrow_root
913 RETURN
mpi_recv
subroutine mpi_recv(buf, cnt, datatype, source, tag, comm, status, ierr)
Definition mpi.f:461
numroc
integer function numroc(n, nb, iproc, isrcproc, nprocs)
Definition mpi.f:786
smumps_quick_sort_arrowheads
recursive subroutine smumps_quick_sort_arrowheads(n, perm, intlist, dbllist, taille, lo, hi)
Definition sarrowheads.F:686
smumps_get_root_info
subroutine smumps_get_root_info(root, local_m, local_n, ptr_root, la)
Definition sarrowheads.F:971
smumps_set_root_to_zero
subroutine smumps_set_root_to_zero(root, keep, a, la)
Definition sarrowheads.F:948

◆ smumps_facto_send_arrowheads()

subroutine smumps_facto_send_arrowheads ( integer n,
integer(8), intent(in) nz,
real, dimension(nz) aspk,
integer, dimension(nz) irn,
integer, dimension(nz) icn,
integer, dimension(n) perm,
logical lscal,
real, dimension(*) colsca,
real, dimension(*) rowsca,
integer myid,
integer slavef,
integer, dimension(keep(28)) procnode_steps,
integer nbrecords,
integer lp,
integer comm,
type (smumps_root_struc) root,
integer, dimension( 500 ) keep,
integer(8), dimension(150) keep8,
integer, dimension( n ) fils,
integer, dimension( n ) rg2l,
integer, dimension( lintarr ) intarr,
integer(8) lintarr,
real, dimension( ldblarr ) dblarr,
integer(8) ldblarr,
integer(8), dimension( n ), intent(inout) ptraiw,
integer(8), dimension( n ), intent(inout) ptrarw,
integer, dimension( keep(28) ) frere_steps,
integer, dimension(n) step,
real, dimension( la ) a,
integer(8), intent(in) la,
integer, dimension(keep(71)) istep_to_iniv2,
logical, dimension(max(1,keep(56))) i_am_cand,
integer, dimension(slavef+1, max(1,keep(56))) candidates )

Definition at line 196 of file sarrowheads.F.

203!$ USE OMP_LIB
204 USE smumps_struc_def, ONLY : smumps_root_struc
205 IMPLICIT NONE
206 INTEGER :: N, COMM, NBRECORDS
207 INTEGER(8), INTENT(IN) :: NZ
208 INTEGER KEEP( 500 )
209 INTEGER(8) KEEP8(150)
210 REAL ASPK(NZ)
211 REAL COLSCA(*), ROWSCA(*)
212 INTEGER IRN(NZ), ICN(NZ)
213 INTEGER PERM(N), PROCNODE_STEPS(KEEP(28))
214 INTEGER RG2L( N ), FILS( N )
215 INTEGER ISTEP_TO_INIV2(KEEP(71))
216 LOGICAL I_AM_CAND(max(1,KEEP(56)))
217 INTEGER LP, SLAVEF, MYID
218 INTEGER CANDIDATES(SLAVEF+1, max(1,KEEP(56)))
219 LOGICAL LSCAL
220 TYPE (SMUMPS_ROOT_STRUC) :: root
221 INTEGER(8), INTENT(IN) :: LA
222 INTEGER(8), INTENT(INOUT) :: PTRAIW( N ), PTRARW( N )
223 INTEGER :: FRERE_STEPS( KEEP(28) )
224 INTEGER :: STEP(N)
225 INTEGER(8) :: LINTARR, LDBLARR
226 INTEGER :: INTARR( LINTARR )
227 REAL :: DBLARR( LDBLARR )
228 REAL :: A( LA )
229 INTEGER, DIMENSION(:,:), ALLOCATABLE :: BUFI
230 REAL, DIMENSION(:,:), ALLOCATABLE :: BUFR
231 INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, numroc,
232 & MUMPS_TYPESPLIT
233 EXTERNAL mumps_procnode, mumps_typenode, numroc,
234 & mumps_typesplit
235 REAL VAL, VAL_SHR
236 INTEGER IOLD,JOLD,ISEND,JSEND,DEST,I,IARR
237 INTEGER ISEND_SHR, JSEND_SHR, DEST_SHR
238 INTEGER IPOSROOT, JPOSROOT
239 INTEGER IROW_GRID, JCOL_GRID
240 INTEGER INODE, ISTEP
241 INTEGER NBUFS
242 INTEGER ARROW_ROOT, TAILLE
243 INTEGER LOCAL_M, LOCAL_N
244 INTEGER(8) :: PTR_ROOT
245 INTEGER TYPE_NODE, MASTER_NODE
246 LOGICAL I_AM_CAND_LOC, I_AM_SLAVE
247 INTEGER JARR, ILOCROOT, JLOCROOT
248 INTEGER allocok, INIV2, TYPESPLIT, T4MASTER
249 INTEGER(8) :: I1, IA, IS1, IAS, ISHIFT, K
250 INTEGER NCAND
251 LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS
252 REAL ZERO
253 parameter( zero = 0.0e0 )
254 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4
255 LOGICAL :: DOIT, OMP_FLAG, OMP_FLAG_P
256 INTEGER NOMP, NOMP_P, IOMP, P2
257 arrow_root = 0
258 earlyt3rootins = keep(200) .EQ. 0
259 & .OR. (keep(200) .LT. 0 .AND. keep(400) .EQ. 0)
260 i_am_slave=(myid.NE.0.OR.keep(46).EQ.1)
261 IF ( keep(46) .eq. 0 ) THEN
262 nbufs = slavef
263 ELSE
264 nbufs = slavef - 1
265 ALLOCATE( iw4( n, 2 ), stat = allocok )
266 IF ( allocok .GT. 0 ) THEN
267 WRITE(*,*) 'Error allocating IW4'
268 CALL mumps_abort()
269 END IF
270#if defined(__ve__)
271!NEC$ IVDEP
272#endif
273 DO i = 1, n
274 i1 = ptraiw( i )
275 ia = ptrarw( i )
276 IF ( ia .GT. 0 ) THEN
277 dblarr( ia ) = zero
278 iw4( i, 1 ) = intarr( i1 )
279 iw4( i, 2 ) = -intarr( i1 + 1 )
280 intarr( i1 + 2 ) = i
281 END IF
282 END DO
283 IF ( keep(38) .NE. 0 .AND. earlyt3rootins ) THEN
284 CALL smumps_get_root_info(root, local_m, local_n,
285 & ptr_root, la)
286 CALL smumps_set_root_to_zero(root, keep, a, la)
287 ELSE
288 local_m = -19999; local_n = -29999; ptr_root = -99999_8
289 END IF
290 END IF
291 IF (nbufs.GT.0) THEN
292 ALLOCATE( bufi(nbrecords*2+1,nbufs),stat=allocok )
293 IF ( allocok .GT. 0 ) THEN
294 WRITE(*,*) 'Error allocating BUFI'
295 CALL mumps_abort()
296 END IF
297 ALLOCATE( bufr( nbrecords, nbufs ), stat=allocok )
298 IF ( allocok .GT. 0 ) THEN
299 WRITE(*,*) 'Error allocating BUFR'
300 CALL mumps_abort()
301 END IF
302 DO i = 1, nbufs
303 bufi( 1, i ) = 0
304 ENDDO
305 ENDIF
306 inode = keep(38)
307 i = 1
308 DO WHILE ( inode .GT. 0 )
309 rg2l( inode ) = i
310 inode = fils( inode )
311 i = i + 1
312 END DO
313 nomp = 1
314!$ NOMP=omp_get_max_threads()
315 omp_flag = keep(399).EQ.1 .AND. nomp.GE.2 .AND. slavef.EQ.1
316 & .AND. keep(46) .EQ. 1
317!$OMP PARALLEL PRIVATE(K, I, DEST, I_AM_CAND_LOC,
318!$OMP& T4MASTER, T4_MASTER_CONCERNED,
319!$OMP& INIV2, NCAND, IROW_GRID, JCOL_GRID,
320!$OMP& ILOCROOT, JLOCROOT, IPOSROOT, JPOSROOT,
321!$OMP& TYPE_NODE, TYPESPLIT, MASTER_NODE,
322!$OMP& IA, ISHIFT, IS1, IAS, TAILLE, VAL,
323!$OMP& IARR, JARR, ISTEP, ISEND, JSEND,
324!$OMP& IOLD, JOLD, IOMP, DOIT, P2, NOMP_P, OMP_FLAG_P)
325!$OMP& REDUCTION(+: ARROW_ROOT) IF (OMP_FLAG)
326 iomp=0
327!$ IOMP=omp_get_thread_num()
328 nomp_p=1
329!$ NOMP_P=omp_get_num_threads()
330 omp_flag_p = .false.
331!$ OMP_FLAG_P = OMP_FLAG .AND. NOMP_P .GT. 1
332 IF (omp_flag_p) THEN
333 IF ( nomp_p .GE. 16 ) THEN
334 nomp_p=16
335 p2 = 4
336 ELSE IF (nomp_p.GE.8) THEN
337 nomp_p=8
338 p2 = 3
339 ELSE IF (nomp_p.GE.4) THEN
340 nomp_p=4
341 p2 = 2
342 ELSE IF (nomp_p.GE.2) THEN
343 nomp_p=2
344 p2 = 1
345 ENDIF
346 ELSE
347 nomp_p = 1
348 p2 = 0
349 ENDIF
350 IF ( iomp .LT. nomp_p ) THEN
351 DO k=1, nz
352 iold = irn(k)
353 jold = icn(k)
354 IF ( (iold.GT.n).OR.(jold.GT.n).OR.(iold.LT.1)
355 & .OR.(jold.LT.1) ) THEN
356 cycle
357 END IF
358 IF (omp_flag_p) THEN
359 IF (iold.EQ.jold) THEN
360 iarr = iold
361 ELSE IF (perm(iold).LT.perm(jold)) THEN
362 iarr = iold
363 ELSE
364 iarr = jold
365 ENDIF
366 doit = ( iomp .EQ. ibits(iarr, p2-1, p2))
367 ELSE
368 doit = .true.
369 ENDIF
370 IF (doit) THEN
371 IF (iold.EQ.jold) THEN
372 isend = iold
373 jsend = jold
374 iarr = iold
375 ELSE IF (perm(iold).LT.perm(jold)) THEN
376 iarr = iold
377 IF ( keep(50) .NE. 0 ) THEN
378 isend = -iold
379 ELSE
380 isend = iold
381 ENDIF
382 jsend = jold
383 ELSE
384 iarr = jold
385 isend = -jold
386 jsend = iold
387 ENDIF
388 istep = abs( step(iarr) )
389 CALL mumps_typeandprocnode( type_node, master_node,
390 & procnode_steps(istep), keep(199) )
391 i_am_cand_loc = .false.
392 t4_master_concerned = .false.
393 t4master = -9999
394 IF ( type_node .EQ. 1 ) THEN
395 IF ( keep(46) .eq. 0 ) THEN
396 dest = master_node + 1
397 ELSE
398 dest = master_node
399 END IF
400 ELSE IF ( type_node .EQ. 2 ) THEN
401 IF ( isend .LT. 0 ) THEN
402 dest = -1
403 ELSE
404 IF ( keep( 46 ) .eq. 0 ) THEN
405 dest = master_node + 1
406 ELSE
407 dest = master_node
408 END IF
409 END IF
410 iniv2 = istep_to_iniv2(istep)
411 IF (i_am_slave) i_am_cand_loc = i_am_cand(iniv2)
412 IF ( keep(79) .GT. 0) THEN
413 typesplit = mumps_typesplit( procnode_steps(istep),
414 & keep(199) )
415 IF ( (typesplit.EQ.5).OR.(typesplit.EQ.6)) THEN
416 t4_master_concerned = .true.
417 t4master=candidates(candidates(slavef+1,iniv2)+1,iniv2)
418 IF ( keep(46) .eq. 0 ) THEN
419 t4master=t4master+1
420 ENDIF
421 ENDIF
422 ENDIF
423 ELSE
424 arrow_root = arrow_root + 1
425 IF (earlyt3rootins) THEN
426 IF ( isend .LT. 0 ) THEN
427 iposroot = rg2l(jsend)
428 jposroot = rg2l(iarr)
429 ELSE
430 iposroot = rg2l( iarr )
431 jposroot = rg2l( jsend )
432 END IF
433 irow_grid = mod( ( iposroot-1 )/root%MBLOCK, root%NPROW )
434 jcol_grid = mod( ( jposroot-1 )/root%NBLOCK, root%NPCOL )
435 IF ( keep( 46 ) .eq. 0 ) THEN
436 dest = irow_grid * root%NPCOL + jcol_grid + 1
437 ELSE
438 dest = irow_grid * root%NPCOL + jcol_grid
439 END IF
440 ELSE
441 dest = -2
442 ENDIF
443 END IF
444 IF (lscal) THEN
445 val = aspk(k)*rowsca(iold)*colsca(jold)
446 ELSE
447 val = aspk(k)
448 ENDIF
449 IF ( dest .eq. 0
450 & .or.
451 & ( dest .eq. -1 .and. keep( 46 ) .eq. 1 .AND.
452 & ( i_am_cand_loc .OR. master_node .EQ. 0 ) )
453 & .or.
454 & ( t4master.EQ.0 )
455 & .or.
456 & ( dest .EQ. -2 .AND. keep( 46 ) .EQ. 1 )
457 & ) THEN
458 iarr = isend
459 jarr = jsend
460 IF ( type_node .eq. 3 .AND. earlyt3rootins ) THEN
461 IF ( irow_grid .EQ. root%MYROW .AND.
462 & jcol_grid .EQ. root%MYCOL ) THEN
463 ilocroot = root%MBLOCK * ( ( iposroot - 1 ) /
464 & ( root%MBLOCK * root%NPROW ) )
465 & + mod( iposroot - 1, root%MBLOCK ) + 1
466 jlocroot = root%NBLOCK * ( ( jposroot - 1 ) /
467 & ( root%NBLOCK * root%NPCOL ) )
468 & + mod( jposroot - 1, root%NBLOCK ) + 1
469 IF (keep(60)==0) THEN
470 a( ptr_root
471 & + int(jlocroot - 1,8) * int(local_m,8)
472 & + int(ilocroot - 1,8) )
473 & = a( ptr_root
474 & + int(jlocroot - 1,8) * int(local_m,8)
475 & + int(ilocroot - 1,8) )
476 & + val
477 ELSE
478 root%SCHUR_POINTER( int(jlocroot - 1,8)
479 & * int(root%SCHUR_LLD,8)
480 & + int(ilocroot,8) )
481 & = root%SCHUR_POINTER( int(jlocroot - 1,8)
482 & * int(root%SCHUR_LLD,8)
483 & + int(ilocroot,8))
484 & + val
485 ENDIF
486 ELSE
487 WRITE(*,*) myid,':INTERNAL Error: root arrowhead '
488 WRITE(*,*) myid,':is not belonging to me. IARR,JARR='
489 & ,iarr,jarr
490 CALL mumps_abort()
491 END IF
492 ELSE IF ( iarr .GE. 0 ) THEN
493 IF ( iarr .eq. jarr ) THEN
494 ia = ptrarw( iarr )
495 dblarr( ia ) = dblarr( ia ) + val
496 ELSE
497 is1 = ptraiw(iarr)
498 ishift = int(intarr(is1) + iw4(iarr,2),8)
499 iw4(iarr,2) = iw4(iarr,2) - 1
500 intarr(is1 + ishift + 2_8) = jarr
501 dblarr(ptrarw(iarr)+ishift) = val
502 END IF
503 ELSE
504 iarr = -iarr
505 ishift = int(ptraiw(iarr)+iw4(iarr,1)+2,8)
506 intarr(ishift) = jarr
507 ias = ptrarw(iarr)+int(iw4(iarr,1),8)
508 iw4(iarr,1) = iw4(iarr,1) - 1
509 dblarr(ias) = val
510 IF ( iw4(iarr,1) .EQ. 0 .AND.
511 & step( iarr) > 0 ) THEN
512 IF ( master_node == myid) THEN
513 taille = intarr( ptraiw(iarr) )
514 CALL smumps_quick_sort_arrowheads( n, perm,
515 & intarr( ptraiw(iarr) + 3 ),
516 & dblarr( ptrarw(iarr) + 1 ),
517 & taille, 1, taille )
518 END IF
519 END IF
520 END IF
521 END IF
522 IF ( dest.EQ. -1 ) THEN
523 iniv2 = istep_to_iniv2(istep)
524 ncand = candidates(slavef+1,iniv2)
525 IF (keep(79).GT.0) THEN
526 DO i=1, slavef
527 dest=candidates(i,iniv2)
528 IF (keep(46).EQ.0.AND.(dest.GE.0)) dest=dest+1
529 IF (dest.LT.0) EXIT
530 IF (i.EQ.ncand+1) cycle
531 IF (dest.NE.0) THEN
532 isend_shr=isend; jsend_shr=jsend
533 val_shr=val; dest_shr=dest
534 CALL smumps_arrow_fill_send_buf()
535 ENDIF
536 ENDDO
537 ELSE
538 DO i=1, ncand
539 dest=candidates(i,iniv2)
540 IF (keep(46).EQ.0) dest=dest+1
541 IF (dest.NE.0) THEN
542 isend_shr=isend; jsend_shr=jsend
543 val_shr=val; dest_shr=dest
544 CALL smumps_arrow_fill_send_buf()
545 ENDIF
546 ENDDO
547 ENDIF
548 dest = master_node
549 IF (keep(46).EQ.0) dest=dest+1
550 IF ( dest .NE. 0 ) THEN
551 isend_shr=isend; jsend_shr=jsend
552 val_shr=val; dest_shr=dest
553 CALL smumps_arrow_fill_send_buf()
554 ENDIF
555 IF ((t4_master_concerned).AND.(t4master.GT.0)) THEN
556 isend_shr=isend; jsend_shr=jsend
557 val_shr=val; dest_shr=t4master
558 CALL smumps_arrow_fill_send_buf()
559 ENDIF
560 ELSE IF ( dest .GT. 0 ) THEN
561 isend_shr=isend; jsend_shr=jsend
562 val_shr=val; dest_shr=dest
563 CALL smumps_arrow_fill_send_buf()
564 IF ( t4master.GT.0 ) THEN
565 isend_shr=isend; jsend_shr=jsend
566 val_shr=val; dest_shr=t4master
567 CALL smumps_arrow_fill_send_buf()
568 ENDIF
569 ELSE IF ( t4master.GT.0 ) THEN
570 isend_shr=isend; jsend_shr=jsend
571 val_shr=val; dest_shr=t4master
572 CALL smumps_arrow_fill_send_buf()
573 ELSE IF ( dest .EQ. -2 ) THEN
574 DO i = 0, slavef-1
575 dest = i
576 IF (keep(46) .EQ. 0) dest = dest + 1
577 IF (dest .NE. 0) THEN
578 isend_shr=isend; jsend_shr=jsend
579 val_shr=val; dest_shr=dest
580 CALL smumps_arrow_fill_send_buf()
581 ENDIF
582 ENDDO
583 ENDIF
584 ENDIF
585 ENDDO
586 ENDIF
587!$OMP END PARALLEL
588 keep(49) = arrow_root
589 IF (nbufs.GT.0) THEN
590 CALL smumps_arrow_finish_send_buf(
591 & bufi, bufr, nbrecords, nbufs,
592 & lp, comm, keep( 46 ) )
593 ENDIF
594 IF ( keep( 46 ) .NE. 0 ) DEALLOCATE( iw4 )
595 IF (nbufs.GT.0) THEN
596 DEALLOCATE( bufi )
597 DEALLOCATE( bufr )
598 ENDIF
599 RETURN
600 CONTAINS
601 SUBROUTINE smumps_arrow_fill_send_buf()
602 IMPLICIT NONE
603 include 'mpif.h'
604 include 'mumps_tags.h'
605 INTEGER IERR
606 INTEGER TAILLE_SENDI, TAILLE_SENDR, IREQ
607 IF (bufi(1,dest_shr)+1.GT.nbrecords) THEN
608 taille_sendi = bufi(1,dest_shr) * 2 + 1
609 taille_sendr = bufi(1,dest_shr)
610 CALL mpi_send(bufi(1,dest_shr),taille_sendi,
611 & mpi_integer,
612 & dest_shr, arrowhead, comm, ierr )
613 CALL mpi_send( bufr(1,dest_shr), taille_sendr,
614 & mpi_real, dest_shr,
615 & arrowhead, comm, ierr )
616 bufi(1,dest_shr) = 0
617 ENDIF
618 ireq = bufi(1,dest_shr) + 1
619 bufi(1,dest_shr) = ireq
620 bufi( ireq * 2, dest_shr ) = isend_shr
621 bufi( ireq * 2 + 1, dest_shr ) = jsend_shr
622 bufr( ireq, dest_shr ) = val_shr
623 RETURN
624 END SUBROUTINE smumps_arrow_fill_send_buf
smumps_arrow_finish_send_buf
subroutine smumps_arrow_finish_send_buf(bufi, bufr, nbrecords, nbufs, lp, comm, type_parall)
Definition sarrowheads.F:660
smumps_arrow_fill_send_buf
subroutine smumps_arrow_fill_send_buf()
Definition sarrowheads.F:602
mumps_typeandprocnode
subroutine mumps_typeandprocnode(tpn, mumps_procnode, procinfo_inode, k199)
Definition tools_common.F:114

◆ smumps_get_root_info()

subroutine smumps_get_root_info ( type (smumps_root_struc), intent(in) root,
integer, intent(out) local_m,
integer, intent(out) local_n,
integer(8), intent(out) ptr_root,
integer(8), intent(in) la )

Definition at line 969 of file sarrowheads.F.

971 USE smumps_struc_def, ONLY : smumps_root_struc
972 IMPLICIT NONE
973 TYPE (SMUMPS_ROOT_STRUC), INTENT(IN) :: root
974 INTEGER, INTENT(OUT) :: LOCAL_M, LOCAL_N
975 INTEGER(8), INTENT(OUT) :: PTR_ROOT
976 INTEGER(8), INTENT(IN) :: LA
977 INTEGER, EXTERNAL :: numroc
978 local_m = numroc( root%ROOT_SIZE, root%MBLOCK,
979 & root%MYROW, 0, root%NPROW )
980 local_m = max( 1, local_m )
981 local_n = numroc( root%ROOT_SIZE, root%NBLOCK,
982 & root%MYCOL, 0, root%NPCOL )
983 ptr_root = la - int(local_m,8) * int(local_n,8) + 1_8
984 RETURN
max
#define max(a, b)
Definition macros.h:21

◆ smumps_quick_sort_arrowheads()

recursive subroutine smumps_quick_sort_arrowheads ( integer n,
integer, dimension( n ) perm,
integer, dimension( taille ) intlist,
real, dimension( taille ) dbllist,
integer taille,
integer lo,
integer hi )

Definition at line 684 of file sarrowheads.F.

686 IMPLICIT NONE
687 INTEGER N, TAILLE
688 INTEGER PERM( N )
689 INTEGER INTLIST( TAILLE )
690 REAL DBLLIST( TAILLE )
691 INTEGER LO, HI
692 INTEGER I,J
693 INTEGER ISWAP, PIVOT
694 REAL sswap
695 i = lo
696 j = hi
697 pivot = perm(intlist((i+j)/2))
698 10 IF (perm(intlist(i)) < pivot) THEN
699 i=i+1
700 GOTO 10
701 ENDIF
702 20 IF (perm(intlist(j)) > pivot) THEN
703 j=j-1
704 GOTO 20
705 ENDIF
706 IF (i < j) THEN
707 iswap = intlist(i)
708 intlist(i) = intlist(j)
709 intlist(j)=iswap
710 sswap = dbllist(i)
711 dbllist(i) = dbllist(j)
712 dbllist(j) = sswap
713 ENDIF
714 IF ( i <= j) THEN
715 i = i+1
716 j = j-1
717 ENDIF
718 IF ( i <= j ) GOTO 10
719 IF ( lo < j ) CALL smumps_quick_sort_arrowheads(n, perm,
720 & intlist, dbllist, taille, lo, j)
721 IF ( i < hi ) CALL smumps_quick_sort_arrowheads(n, perm,
722 & intlist, dbllist, taille, i, hi)
723 RETURN
sswap
subroutine sswap(n, sx, incx, sy, incy)
SSWAP
Definition sswap.f:82

◆ smumps_set_root_to_zero()

subroutine smumps_set_root_to_zero ( type (smumps_root_struc) root,
integer, dimension(500) keep,
real, dimension(la), intent(inout) a,
integer(8), intent(in) la )

Definition at line 947 of file sarrowheads.F.

948 USE smumps_struc_def, ONLY : smumps_root_struc
949 IMPLICIT NONE
950 INTEGER(8), INTENT(IN) :: LA
951 REAL, INTENT(INOUT) :: A(LA)
952 INTEGER :: KEEP(500)
953 TYPE (SMUMPS_ROOT_STRUC) :: root
954 INTEGER :: LOCAL_M, LOCAL_N
955 INTEGER(8) :: PTR_ROOT
956 IF (keep(60)==0) THEN
957 CALL smumps_get_root_info(root, local_m, local_n, ptr_root, la)
958 IF (local_n .GT. 0) THEN
959 CALL smumps_set_to_zero(a(ptr_root),
960 & local_m, local_m, local_n, keep)
961 ENDIF
962 ELSE IF (root%yes) THEN
963 CALL smumps_set_to_zero(root%SCHUR_POINTER(1),
964 & root%SCHUR_LLD, root%SCHUR_MLOC, root%SCHUR_NLOC,
965 & keep)
966 ENDIF
967 RETURN
smumps_set_to_zero
subroutine smumps_set_to_zero(a, lld, m, n, keep)
Definition sarrowheads.F:916

◆ smumps_set_to_zero()

subroutine smumps_set_to_zero ( real, dimension(int(lld,8)*int(n-1,8)+int(m,8)) a,
integer, intent(in) lld,
integer, intent(in) m,
integer, intent(in) n,
integer, dimension(500) keep )

Definition at line 915 of file sarrowheads.F.

916!$ USE OMP_LIB, ONLY : OMP_GET_MAX_THREADS
917 IMPLICIT NONE
918 INTEGER, INTENT(IN) :: LLD, M, N
919 REAL :: A(int(LLD,8)*int(N-1,8)+int(M,8))
920 INTEGER :: KEEP(500)
921 REAL, PARAMETER :: ZERO = 0.0e0
922 INTEGER I, J
923!$ INTEGER :: NOMP
924 INTEGER(8) :: I8, LA
925!$ NOMP = OMP_GET_MAX_THREADS()
926 IF (lld .EQ. m) THEN
927 la=int(lld,8)*int(n-1,8)+int(m,8)
928!$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC,KEEP(361))
929!$OMP& IF ( LA > int(KEEP(361),8) .AND. NOMP .GT. 1)
930 DO i8=1, la
931 a(i8) = zero
932 ENDDO
933!$OMP END PARALLEL DO
934 ELSE
935!$OMP PARALLEL DO PRIVATE(I,J) COLLAPSE(2)
936!$OMP& SCHEDULE(STATIC,KEEP(361)) IF (int(M,8)*int(N,8)
937!$OMP& .GT. KEEP(361).AND. NOMP .GT.1)
938 DO i = 1, n
939 DO j = 1, m
940 a( int(i-1,8)*int(lld,8)+ int(j,8) ) = zero
941 ENDDO
942 ENDDO
943!$OMP END PARALLEL DO
944 ENDIF
945 RETURN