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

Go to the source code of this file.

Functions/Subroutines

subroutine zmumps_ana_dist_arrowheads (myid, slavef, n, procnode, step, ptraiw, ptrarw, istep_to_iniv2, i_am_cand, keep, keep8, icntl, id)
subroutine zmumps_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 zmumps_arrow_fill_send_buf ()
subroutine zmumps_arrow_fill_send_buf_elt (isend_shr, jsend_shr, val_shr, dest_shr, bufi, bufr, nbrecords, nbufs, lp, comm)
subroutine zmumps_arrow_finish_send_buf (bufi, bufr, nbrecords, nbufs, lp, comm, type_parall)
recursive subroutine zmumps_quick_sort_arrowheads (n, perm, intlist, dbllist, taille, lo, hi)
subroutine zmumps_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 zmumps_set_to_zero (a, lld, m, n, keep)
subroutine zmumps_set_root_to_zero (root, keep, a, la)
subroutine zmumps_get_root_info (root, local_m, local_n, ptr_root, la)

Function/Subroutine Documentation

◆ zmumps_ana_dist_arrowheads()

subroutine zmumps_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 (zmumps_struc) id )

Definition at line 14 of file zarrowheads.F.

18 USE zmumps_struc_def
19 IMPLICIT NONE
20 TYPE (ZMUMPS_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
zmumps_struc_def
Definition zmumps_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

◆ zmumps_arrow_fill_send_buf()

subroutine zmumps_facto_send_arrowheads::zmumps_arrow_fill_send_buf

Definition at line 601 of file zarrowheads.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_double_complex, 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

◆ zmumps_arrow_fill_send_buf_elt()

subroutine zmumps_arrow_fill_send_buf_elt ( integer, intent(in) isend_shr,
integer, intent(in) jsend_shr,
complex(kind=8), intent(in) val_shr,
integer dest_shr,
integer, dimension( nbrecords*2+1, nbufs ) bufi,
complex(kind=8), dimension( nbrecords, nbufs ) bufr,
integer nbrecords,
integer nbufs,
integer lp,
integer comm )

Definition at line 626 of file zarrowheads.F.

629 IMPLICIT NONE
630 INTEGER, INTENT(in) :: ISEND_SHR, JSEND_SHR
631 COMPLEX(kind=8), INTENT(in) :: VAL_SHR
632 INTEGER :: DEST_SHR, NBRECORDS, NBUFS, LP, COMM
633 INTEGER :: BUFI( NBRECORDS*2+1, NBUFS )
634 COMPLEX(kind=8) :: 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_double_complex, 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

◆ zmumps_arrow_finish_send_buf()

subroutine zmumps_arrow_finish_send_buf ( integer, dimension( nbrecords * 2 + 1, nbufs ) bufi,
complex(kind=8), dimension( nbrecords, nbufs ) bufr,
integer nbrecords,
integer nbufs,
integer lp,
integer comm,
integer type_parall )

Definition at line 657 of file zarrowheads.F.

660 IMPLICIT NONE
661 INTEGER NBUFS, NBRECORDS, TYPE_PARALL
662 INTEGER BUFI( NBRECORDS * 2 + 1, NBUFS )
663 COMPLEX(kind=8) 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_double_complex, islave,
679 & arrowhead, comm, ierr )
680 END IF
681 ENDDO
682 RETURN

◆ zmumps_facto_recv_arrowhd2()

subroutine zmumps_facto_recv_arrowhd2 ( integer n,
complex(kind=8), 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,
complex(kind=8), dimension( la ) a,
integer(8), intent(in) la,
type (zmumps_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 zarrowheads.F.

732 USE zmumps_struc_def, ONLY : zmumps_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 COMPLEX(kind=8) A( LA )
744 INTEGER INFO1, INFO2
745 COMPLEX(kind=8) DBLARR(LDBLARR)
746 INTEGER FRERE_STEPS( KEEP(28) ), STEP(N)
747 TYPE (ZMUMPS_ROOT_STRUC) :: root
748 INTEGER, POINTER, DIMENSION(:) :: BUFI
749 COMPLEX(kind=8), 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 COMPLEX(kind=8) VAL
764 COMPLEX(kind=8) ZERO
765 parameter( zero = (0.0d0,0.0d0) )
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 zmumps_get_root_info(root, local_m, local_n, ptr_root, la)
801 CALL zmumps_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_double_complex,
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 zmumps_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
zmumps_quick_sort_arrowheads
recursive subroutine zmumps_quick_sort_arrowheads(n, perm, intlist, dbllist, taille, lo, hi)
Definition zarrowheads.F:686
zmumps_set_root_to_zero
subroutine zmumps_set_root_to_zero(root, keep, a, la)
Definition zarrowheads.F:948
zmumps_get_root_info
subroutine zmumps_get_root_info(root, local_m, local_n, ptr_root, la)
Definition zarrowheads.F:971

◆ zmumps_facto_send_arrowheads()

subroutine zmumps_facto_send_arrowheads ( integer n,
integer(8), intent(in) nz,
complex(kind=8), dimension(nz) aspk,
integer, dimension(nz) irn,
integer, dimension(nz) icn,
integer, dimension(n) perm,
logical lscal,
double precision, dimension(*) colsca,
double precision, dimension(*) rowsca,
integer myid,
integer slavef,
integer, dimension(keep(28)) procnode_steps,
integer nbrecords,
integer lp,
integer comm,
type (zmumps_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,
complex(kind=8), 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,
complex(kind=8), 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 zarrowheads.F.

203!$ USE OMP_LIB
204 USE zmumps_struc_def, ONLY : zmumps_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 COMPLEX(kind=8) ASPK(NZ)
211 DOUBLE PRECISION 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 (ZMUMPS_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 COMPLEX(kind=8) :: DBLARR( LDBLARR )
228 COMPLEX(kind=8) :: A( LA )
229 INTEGER, DIMENSION(:,:), ALLOCATABLE :: BUFI
230 COMPLEX(kind=8), DIMENSION(:,:), ALLOCATABLE :: BUFR
231 INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, numroc,
232 & MUMPS_TYPESPLIT
233 EXTERNAL mumps_procnode, mumps_typenode, numroc,
234 & mumps_typesplit
235 COMPLEX(kind=8) 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 COMPLEX(kind=8) ZERO
253 parameter( zero = (0.0d0,0.0d0) )
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 zmumps_get_root_info(root, local_m, local_n,
285 & ptr_root, la)
286 CALL zmumps_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 zmumps_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 zmumps_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 zmumps_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 zmumps_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 zmumps_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 zmumps_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 zmumps_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 zmumps_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 zmumps_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 zmumps_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 zmumps_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_double_complex, 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 zmumps_arrow_fill_send_buf
mumps_typeandprocnode
subroutine mumps_typeandprocnode(tpn, mumps_procnode, procinfo_inode, k199)
Definition tools_common.F:114
zmumps_arrow_finish_send_buf
subroutine zmumps_arrow_finish_send_buf(bufi, bufr, nbrecords, nbufs, lp, comm, type_parall)
Definition zarrowheads.F:660
zmumps_arrow_fill_send_buf
subroutine zmumps_arrow_fill_send_buf()
Definition zarrowheads.F:602

◆ zmumps_get_root_info()

subroutine zmumps_get_root_info ( type (zmumps_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 zarrowheads.F.

971 USE zmumps_struc_def, ONLY : zmumps_root_struc
972 IMPLICIT NONE
973 TYPE (ZMUMPS_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

◆ zmumps_quick_sort_arrowheads()

recursive subroutine zmumps_quick_sort_arrowheads ( integer n,
integer, dimension( n ) perm,
integer, dimension( taille ) intlist,
complex(kind=8), dimension( taille ) dbllist,
integer taille,
integer lo,
integer hi )

Definition at line 684 of file zarrowheads.F.

686 IMPLICIT NONE
687 INTEGER N, TAILLE
688 INTEGER PERM( N )
689 INTEGER INTLIST( TAILLE )
690 COMPLEX(kind=8) DBLLIST( TAILLE )
691 INTEGER LO, HI
692 INTEGER I,J
693 INTEGER ISWAP, PIVOT
694 COMPLEX(kind=8) zswap
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 zswap = dbllist(i)
711 dbllist(i) = dbllist(j)
712 dbllist(j) = zswap
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 zmumps_quick_sort_arrowheads(n, perm,
720 & intlist, dbllist, taille, lo, j)
721 IF ( i < hi ) CALL zmumps_quick_sort_arrowheads(n, perm,
722 & intlist, dbllist, taille, i, hi)
723 RETURN
zswap
subroutine zswap(n, zx, incx, zy, incy)
ZSWAP
Definition zswap.f:81

◆ zmumps_set_root_to_zero()

subroutine zmumps_set_root_to_zero ( type (zmumps_root_struc) root,
integer, dimension(500) keep,
complex(kind=8), dimension(la), intent(inout) a,
integer(8), intent(in) la )

Definition at line 947 of file zarrowheads.F.

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

◆ zmumps_set_to_zero()

subroutine zmumps_set_to_zero ( complex(kind=8), 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 zarrowheads.F.

916!$ USE OMP_LIB, ONLY : OMP_GET_MAX_THREADS
917 IMPLICIT NONE
918 INTEGER, INTENT(IN) :: LLD, M, N
919 COMPLEX(kind=8) :: A(int(LLD,8)*int(N-1,8)+int(M,8))
920 INTEGER :: KEEP(500)
921 COMPLEX(kind=8), PARAMETER :: ZERO = (0.0d0,0.0d0)
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