1 : C PRGPSK SOURCE CHAT 05/01/13 02:26:27 5004
2 : SUBROUTINE PRGPSK(ADJAC,OPTPRO,
3 : $ NEWNUM,
4 : $ IMPR,IRET)
5 : IMPLICIT INTEGER(I-N)
6 : IMPLICIT REAL*8 (A-H,O-Z)
7 : C***********************************************************************
8 : C NOM : PRGPSK
9 : C DESCRIPTION : Renumérotation d'un graphe symétrique par la méthode de
10 : C Gibbs-King ou de Gibbs-Poole-Stockmeyer.
11 : C Prépare la renumérotation par la méthode de
12 : C 1) Gibbs-King si OPTPRO = .TRUE. (réduction du profile)
13 : C 1) Gibbs-Poole-Stockmeyer
14 : C si OPTPRO = .FALSE. (bandwidth reduction)
15 : C
16 : C LANGAGE : ESOPE
17 : C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/TTMF)
18 : C mél : gounand@semt2.smts.cea.fr
19 : C BIBLIO : @Article{,
20 : C author = {S. W. Sloan},
21 : C title = {A Fortran Program for Profile and Wavefront Reduction},
22 : C journal = {International Journal for Numerical Methods in Engineering},
23 : C year = {1989},
24 : C volume = {28},
25 : C pages = {2651-2679}
26 : C}
27 : C
28 : C***********************************************************************
29 : C APPELES : GPSKCA, PROFI1
30 : C APPELE PAR : RENUME
31 : C***********************************************************************
32 : C ENTREES : ADJAC, OPTPRO
33 : C SORTIES : NEWNUM
34 : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
35 : C***********************************************************************
36 : C VERSION : v1, 10/11/99, version initiale
37 : C HISTORIQUE : v1, 10/11/99, création
38 : C HISTORIQUE :
39 : C HISTORIQUE :
40 : C***********************************************************************
41 : C Prière de PRENDRE LE TEMPS de compléter les commentaires
42 : C en cas de modification de ce sous-programme afin de faciliter
43 : C la maintenance !
44 : C***********************************************************************
45 : -INC CCOPTIO
46 : -INC SMLENTI
47 : INTEGER JG
48 : POINTEUR IWORK.MLENTI
49 : POINTEUR NEWNUM.MLENTI
50 : POINTEUR DEGREE.MLENTI
51 : *
52 : * Segment LSTIND (liste séquentielle indexée)
53 : *
54 : SEGMENT LSTIND
55 : INTEGER IDX(NBM+1)
56 : INTEGER IVAL(NBTVAL)
57 : ENDSEGMENT
58 : *
59 : * LISTE SEQUENTIELLE INDEXEE D'ENTIERS
60 : *
61 : * NBM : NOMBRE DE MULTIPLETS
62 : * NBTVAL : NOMBRE TOTAL DE VALEURS
63 : * IDX(I) : INDICE DE LA PREMIERE VALEUR DU IEME
64 : * MULTIPLET DANS LE TABLEAU IVAL
65 : * IVAL(IDX(I) -> IDX(I+1)-1) : VALEURS DU IEME MULTIPLET
66 : *
67 : *-INC SLSTIND
68 : POINTEUR ADJAC.LSTIND
69 : INTEGER IMPR,IRET
70 : *
71 : INTEGER ITOTPO
72 : INTEGER NTOTPO
73 : LOGICAL OPTPRO
74 : INTEGER WRKLEN,BANDWD,PROFI,ERROR,SPACE
75 : *
76 : * Executable statements
77 : *
78 : IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans prgpsk'
79 : SEGACT ADJAC
80 : NTOTPO=ADJAC.IDX(/1)-1
81 : JG=NTOTPO
82 : SEGINI DEGREE
83 : DO 1 ITOTPO=1,NTOTPO
84 : DEGREE.LECT(ITOTPO)=ADJAC.IDX(ITOTPO+1)
85 : $ -ADJAC.IDX(ITOTPO)
86 : 1 CONTINUE
87 : JG=NTOTPO
88 : SEGINI NEWNUM
89 : DO 3 ITOTPO=1,NTOTPO
90 : NEWNUM.LECT(ITOTPO)=ITOTPO
91 : 3 CONTINUE
92 : WRKLEN=(6*NTOTPO)+3
93 : JG=WRKLEN
94 : SEGINI IWORK
94 : CALL GPSKCA(NTOTPO,DEGREE.LECT,ADJAC.IDX,ADJAC.IVAL,OPTPRO,WRKLEN,
95 : $ NEWNUM.LECT,
96 : $ IWORK.LECT,
97 : $ BANDWD,PROFI,
98 : $ ERROR,SPACE)
99 : IF (ERROR.NE.0) THEN
100 : WRITE(IOIMP,*) 'ERROR=',ERROR, 'in GPSKCA'
101 : GOTO 9999
102 : ENDIF
103 : SEGSUP IWORK
104 : SEGSUP DEGREE
105 : SEGDES NEWNUM
106 : SEGDES ADJAC
107 : IF (IMPR.GT.3) THEN
108 : WRITE(IOIMP,*) 'BANDWD = ',BANDWD
109 : WRITE(IOIMP,*) 'PROFI = ',PROFI
110 : ENDIF
111 : *
112 : * Normal termination
113 : *
114 : IRET=0
115 : RETURN
116 : *
117 : * Format handling
118 : *
119 : *
120 : * Error handling
121 : *
122 : 9999 CONTINUE
123 : IRET=1
124 : WRITE(IOIMP,*) 'An error was detected in subroutine prgpsk'
125 : RETURN
126 : *
127 : * End of subroutine PRGPSK
128 : *
129 : END
130 :
131 :
132 :
133 :
© Cast3M 2003 - All rights reserved.
Disclaimer