1 : C COMBT1 SOURCE PV 11/03/08 21:15:15 6888 2 : SUBROUTINE COMBT1 (IPCHP1,IPTABL,COMBIN,IPCHP2) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : ************************************************************************ 6 : * 7 : * C O M B T 1 8 : * ----------- 9 : * 10 : * FONCTION: 11 : * --------- 12 : * 13 : * EFFECTUER LA COMBINAISON LINEAIRE DE CHPOINTS CONSIGNES DANS UNE 14 : * TABLE, INDICES PAR DES POINTS. 15 : * 16 : * MODE D'APPEL: 17 : * ------------- 18 : * 18 : * CALL COMBT1 (IPCHP1,IPTABL,COMBIN,IPCHP2) 19 : * 20 : * PARAMETRES: (E)=ENTREE (S)=SORTIE 21 : * ----------- 22 : * 23 : * IPCHP1 ENTIER (E) POINTEUR SUR LE CHPOINT DES COEFFICIENTS DE 24 : * PONDERATION (VOIR LE SOUS-PROGRAMME 25 : * "COMBTA" OU L'OPERATEUR "COMBTABLE" POUR LE 26 : * DETAIL DE SON CONTENU). 27 : * IPTABL ENTIER (E) POINTEUR SUR LA TABLE DES CHPOINTS. 28 : * COMBIN SUBROUT. (E) SOUS-PROGRAMME DE COMBINAISON LINEAIRE DE 29 : * 2 CHPOINTS. 5 ARGUMENTS: 30 : * - CHPOINT N.1 , 31 : * - REEL D.P. N.1 , 32 : * - CHPOINT N.2 , 33 : * - REEL D.P. N.2 , 34 : * - CHPOINT COMBINAISON LINEAIRE. 35 : * IPCHP2 ENTIER (S) POINTEUR SUR LE CHPOINT COMBINE. 36 : * 37 : * AUTEUR, DATE DE CREATION: 38 : * ------------------------- 39 : * 40 : * PASCAL MANIGOT 30 MAI 1985 41 : * 42 : * LANGAGE: 43 : * -------- 44 : * 45 : * ESOPE + FORTRAN77 + EXTENSION: CARACTERES MIS DANS DES ENTIERS. 46 : * 47 : ************************************************************************ 48 : * 49 : -INC CCOPTIO 50 : -INC SMCHPOI 51 : -INC SMELEME 52 : -INC SMTABLE 53 : -INC SMVECTD 54 : * 55 : LOGICAL FIRST,LBID 56 : CHARACTER*1 CBID 57 : EXTERNAL COMBIN 58 : * 59 : * 60 : 61 : FIRST = .TRUE. 62 : MCHPOI = IPCHP1 63 : SEGACT,MCHPOI 64 : * 65 : NSOUPO = IPCHP(/1) 66 : DO 100 IB100=1,NSOUPO 67 : * 68 : MSOUPO = IPCHP(IB100) 69 : SEGACT,MSOUPO 70 : NC = NOCOMP(/2) 71 : IF (NC .NE. 1) THEN 72 : * LE CHPOINT DES COEFFICIENTS DE PONDERATION A PLUSIEURS 73 : * COMPOSANTES: ON NE SAIT PAS QUOI EN FAIRE. 74 : NUMERR = 180 74 : CALL ERREUR (NUMERR) 75 : RETURN 76 : END IF 77 : * 78 : MELEME = IGEOC 79 : SEGACT,MELEME 80 : NBNN = NUM(/1) 81 : IF (NBNN .NE. 1) THEN 82 : * ON NE COMPREND PAS QUE L'OBJET "MAILLAGE" NE CONTIENNE PAS 83 : * DES ELEMENTS A 1 SEUL NOEUD. 84 : MOTERR(1:8) = '"COMBT1"' 85 : NUMERR = 224 85 : CALL ERREUR (NUMERR) 86 : RETURN 87 : END IF 88 : * 89 : MPOVAL = IPOVAL 90 : SEGACT,MPOVAL 91 : NBPOIN = VPOCHA(/1) 92 : NBELEM = NUM(/2) 93 : IF (NBPOIN .NE. NBELEM) THEN 94 : * TYPE DE RELATION ENTRE LE 'CHPOINT' ET SON SUPPORT INCOMPRIS 95 : MOTERR(1:8) = '"COMBT1"' 96 : NUMERR = 224 96 : CALL ERREUR (NUMERR) 97 : RETURN 98 : END IF 99 : * 100 : mtable=iptabl 101 : segact mtable,mtab1 102 : DO 110 IB110=1,NBPOIN 103 : INDICE = NUM(1,IB110) 104 : do iou=1,mlotab 105 : if(mtabii(iou).eq.indice) go to 32 106 : enddo 106 : call erreur(5) 107 : 32 continue 108 : ipchp3=mtabiv(iou) 109 : mvect1= mtab1.mtabiv(iou) 110 : INDICE = NUM(1,IB110) 111 : write(6,*) ib110 ,'ieme point numero ' , indice 111 : * CALL ACCTAB (IPTABL,'POINT',IBID,XBID,CBID,LBID,INDICE 112 : * & ,'CHPOINT',IBID,XBID,CBID,LBID,IPCHP3) 113 : * IF (IERR .NE. 0) RETURN 114 : * segact mvect1 115 : COEFF3 = VPOCHA(IB110,1) 116 : IF (FIRST) THEN 117 : inc=mvect1.vectbb(/1) 118 : segini,mvect3 119 : do iau=1,mvect1.vectbb(/1) 120 : mvect3.vectbb(iau)=mvect1.vectbb(iau)*coeff3 121 : enddo 122 : FIRST = .FALSE. 123 : * MULTPL = 1 123 : * CALL MUCHPO (IPCHP3,COEFF3, IPCHP2,MULTPL) 124 : * IF (IERR .NE. 0) RETURN 125 : ELSE 126 : do iau=1,inc 127 : mvect3.vectbb(iau)=mvect3.vectbb(iau)+ 128 : $ coeff3*mvect1.vectbb(iau) 129 : enddo 130 : 131 : * COEFF2 = 1.D0 131 : * CALL COMBIN (IPCHP2,COEFF2,IPCHP3,COEFF3, IPCHP9) 132 : * IF (IERR .NE. 0) RETURN 132 : * CALL DTCHPO (IPCHP2) 133 : * IPCHP2 = IPCHP9 134 : END IF 135 : * 136 : 110 CONTINUE 136 : *** call crech2(ipchp2,mvect3,mvecri,1) 137 : *** segsup mvect3 138 : segdes mtable,mtab1 139 : * END DO 140 : * 141 : SEGDES,MELEME 142 : SEGDES,MPOVAL 143 : SEGDES,MSOUPO 144 : * 145 : 100 CONTINUE 146 : * END DO 147 : * 148 : SEGDES,MCHPOI 149 : * 150 : END 151 : 152 : 153 : 154 :
© Cast3M 2003 - All rights reserved.
Disclaimer