1 : C SOSOLF SOURCE FANDEUR 10/12/14 21:19:50 6812 2 : SUBROUTINE SOSOLF(ICOLAC,MSOLUT,IFORM) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : C======================================================================= 6 : C CE SUBROUTINE ECRIT SUR LE FICHIER IOSAU UN OBJET MSOLUT 7 : C APPELE PAR WRPIL 8 : C APPELLE : SOPAPF ECDIFE ECDIFR 9 : C ECRIT PAR FARVACQUE - REPRIS PAR LENA 10 : C======================================================================= 11 : C 12 : DIMENSION ILENA(10) 13 : -INC CCOPTIO 14 : -INC SMELEME 15 : -INC SMCHPOI 16 : -INC SMSOLUT 17 : -INC TMCOLAC 18 : 19 : SEGMENT/ITBBE1/( ITABE1(NN)) 20 : SEGMENT/ITBBE2/( ITABE2(NN)) 21 : SEGMENT/ITBBE3/(ITABE3(L3,N3)) 22 : SEGMENT/ITAB/(TAB(N1),ITABB(N2)) 23 : C 24 : 8000 FORMAT(16I5) 25 : 8001 FORMAT(16(1X,A4)) 26 : 8002 FORMAT(1P,6E13.6) 27 : 8003 FORMAT(' ENREGISTREMENT DE TYPE',I4) 28 : 8004 FORMAT(' PILE NUMERO',I4,' NBRE OBJETS NOMMES',I4,' NBRE OBJETS', 29 : 1 I4) 30 : C 31 : SEGACT ICOLAC 32 : ILENA(1)=0 33 : ILENA(2)=0 34 : ILENA(3)=0 35 : IF (MSOLUT.EQ.0) GO TO 10 36 : ITLAC1=KCOLA(1) 37 : C 38 : SEGACT MSOLUT 39 : NIPO=MSOLIS(/1) 40 : NIPO1=NIPO-4 41 : L3=3 42 : C WRITE(IOSAU,8000)NIPO1,MSOLIS(3),L3 43 : ILENA(1) = NIPO1 44 : ILENA(2) = MSOLIS(3) 45 : ILENA(3) = L3 46 : 10 NTOTO=3 46 : CALL ECDIFE (IOSAU,NTOTO,ILENA(1),IFORM) 47 : IF (MSOLUT.EQ.0) GO TO 11 48 : C WRITE(IOSAU,8001) ITYSOL(1),ITYSOL(2) 49 : NTOTO=2 50 : READ (ITYSOL,FMT='(2A4)') ILENA(1),ILENA(2) 50 : CALL ECDIFM (IOSAU,NTOTO,ILENA,IFORM) 51 : IF(MSOLIS(3).EQ.0) GOTO 1808 52 : CCC IVA=MSOLIS(3) 53 : CCC MSOLIS(3)=ITLAC1.ITLAC(IVA) 54 : 1808 CONTINUE 55 : NN=2*NIPO1 56 : SEGINI ITBBE1 57 : NN=2*NIPO1+1 58 : SEGINI ITBBE2 59 : ITABE2(1)=0 60 : DO 1803 II=5,NIPO 61 : III=II-4 62 : IF(MSOLIS(II).EQ.0) GOTO 1820 63 : MSOLEN=MSOLIS(II) 64 : SEGACT MSOLEN 65 : NPAS=ISOLEN(/1) 66 : DO 1801 I=1,ISOLEN(/1) 67 : IF(ISOLEN(I).EQ.0) GOTO 1801 68 : IIVA=ISOLEN(I) 69 : GOTO 1802 70 : 1801 CONTINUE 71 : 1802 ISOLIT=MSOLIT(II) 72 : IF(ISOLIT.NE.2) GOTO 1805 73 : C CHPOINT +++++++++++++ 74 : MCHPOI=IIVA 75 : ITLAC2=KCOLA(2) 76 : L=ITLAC2.ITLAC(/1) 77 : DO 1856 I=1,L 78 : IF(ITLAC2.ITLAC(I).NE.MCHPOI) GOTO 1856 79 : IVA=I 80 : GOTO 1857 81 : 1856 CONTINUE 82 : 1857 CONTINUE 83 : SEGACT MCHPOI 84 : NSOU=IPCHP(/1) 85 : ITABE2(III+1)=ITABE2(III)+NSOU 86 : ITABE1(2*III)=IVA 87 : ITABE1(2*III-1)=ISOLIT 88 : SEGDES MCHPOI 89 : SEGDES MSOLEN 90 : GOTO 1803 91 : 1805 IF(ISOLIT.NE.5) GOTO 1806 92 : WRITE(IOIMP,*) 'SOSOLF : CAS ISOLIT=5 N ETANT PLUS UTILISE' 93 : SEGDES MSOLEN 94 : GOTO 1803 95 : 1806 CONTINUE 96 : C 97 : 1820 ITABE1(2*III)=0 98 : ITABE1(2*III-1)=0 99 : ITABE2(III+1)=ITABE2(III) 100 : 1803 CONTINUE 101 : C ITABE3(L3,N3) ON CALCULE TOUTES LES LONGUEURS 102 : C DES TABLEAUX A LIRE 103 : N3=ITABE2(NIPO1+1) 104 : SEGINI ITBBE3 105 : DO 1840 III=1,NIPO1 106 : IF(ITABE1(2*III).EQ.0) GOTO 1840 107 : ISOLIT=ITABE1(2*III-1) 108 : IF(ISOLIT.NE.2) GOTO 1842 109 : C MCHPOI +++++++++++++++ 110 : ITLAC2=KCOLA(2) 111 : MCHPOI=ITLAC2.ITLAC(ITABE1(2*III)) 112 : SEGACT MCHPOI 113 : DO 1850 ISOU=1,IPCHP(/1) 114 : MSOUPO=IPCHP(ISOU) 115 : SEGACT MSOUPO 116 : MPOVAL=IPOVAL 117 : SEGACT MPOVAL 118 : J=ITABE2(III)+ISOU 119 : ITABE3(1,J)=VPOCHA(/1) 120 : ITABE3(2,J)=VPOCHA(/2) 121 : SEGDES MPOVAL,MSOUPO 122 : 1850 CONTINUE 123 : SEGDES MCHPOI 124 : GOTO 1840 125 : 1842 IF(ISOLIT.NE.5) GOTO 1843 126 : WRITE(IOIMP,*) 'SOSOLF : CAS ISOLIT=5 N ETANT PLUS UTILISE' 127 : GOTO 1840 128 : 1843 CONTINUE 129 : 1840 CONTINUE 130 : L=2*NIPO1 130 : CALL ECDIFE(IOSAU,L,ITABE1,IFORM) 131 : L=NIPO1+1 131 : CALL ECDIFE(IOSAU,L,ITABE2,IFORM) 132 : L=L3*N3 132 : CALL ECDIFE(IOSAU,L,ITABE3,IFORM) 133 : SEGSUP ITBBE3 134 : SEGSUP ITBBE1 135 : N1=7 136 : N2=4+NIPO1 137 : SEGINI ITAB 138 : DO 1830 IPAS=1,NPAS 138 : CALL SOPAPF(MSOLUT,IPAS,ITAB,ITBBE2,IFORM) 139 : 1830 CONTINUE 140 : SEGSUP ITBBE2,ITAB 141 : SEGDES MSOLUT 142 : IQUOI=6 143 : C WRITE(IOSAU,8003)IQUOI 143 : CALL ECDES (IOSAU,IQUOI,IFORM) 144 : 11 RETURN 145 : END 146 : 147 :
© Cast3M 2003 - All rights reserved.
Disclaimer