C WRMTIK SOURCE PV 20/09/26 21:20:17 10724 SUBROUTINE WRMTIK(IFSAU,ITLACC,IMAX1,IFORM,IDEB) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) C*********************************************************************** C NOM : WRMTIK C DESCRIPTION : Ecriture des objets de type MATRIK sur le C fichier IFSAU C (appelé par wrpil.eso) C C LANGAGE : ESOPE C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/TTMF) C mél : gounand@semt2.smts.cea.fr C*********************************************************************** C APPELES (E/S) : ECDIFE (ecriture d'un tableau d'entiers) C ECDIFR (ecriture d'un tableau de REAL*8) C ECDIFM (ecriture d'un tableau de CHARACTER*4) C*********************************************************************** C SYNTAXE GIBIANE : SAUV C ENTREES : IFSAU, numéro du fichier en écriture C IDEB, IMAX1, indice de début et de fin C de la pile des objets MATRIK (ITLACC) C à écrire. C IFORM, le fichier a ecrire est formaté ou C non. C*********************************************************************** C VERSION : v1, 15/07/98, version initiale C HISTORIQUE : v1, 15/07/98, création C HISTORIQUE : C HISTORIQUE : C*********************************************************************** C Prière de PRENDRE LE TEMPS de compléter les commentaires C en cas de modification de ce sous-programme afin de faciliter C la maintenance ! C*********************************************************************** -INC PPARAM -INC CCOPTIO -INC SMMATRIK -INC TMCOLAC SEGMENT/ITBBM1/( ITABM1(NM)) C INTEGER NDTAB INTEGER IEL,I,J,K,L INTEGER ILENA(11) INTEGER IV1,IV2,IV3,IV4 C====================================================================== * * Executable statements * C C ... BOUCLE SUR LES MATRIK DE LA PILE NM=0 SEGINI ITBBM1 DO 1 IEL=IDEB,IMAX1 MATRIK=ITLAC(IEL) IF (MATRIK.EQ.0) THEN WRITE(IOIMP,*) 'Failing to save a nil pointer' WRITE(IOIMP,*) 'MATRIK type object...' GOTO 9999 ENDIF C.... On initialise des piles d'objets non connus de CASTEM C MINC, PMORS, IZA, IDMAT C (Pb : des entiers distincts (par ex. KISPGP, KISPGT) C peuvent etre egaux (i.e. pointer sur le meme objet) C On ne veut pas sauvegarder l'objet deux fois...) SEGINI ITLAC1 SEGINI ITLAC2 SEGINI ITLAC3 SEGINI ITLAC4 C Sauvegarde du chapeau C Dimensions SEGACT MATRIK NRIGE =IRIGEL(/1) NMATRI=IRIGEL(/2) NKID=KIDMAT(/1) NKMT=KKMMT(/1) ILENA(1)=NRIGE ILENA(2)=NMATRI ILENA(3)=NKID ILENA(4)=NKMT NDTAB=4 CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) C Rigidités élémentaires NDTAB = NRIGE * NMATRI CALL ECDIFE(IFSAU,NDTAB,IRIGEL,IFORM) C Matrice assemblée ILENA( 1)=KSYM ILENA( 2)=KMINC ILENA( 3)=KMINCP ILENA( 4)=KMINCD ILENA( 5)=KIZM ILENA( 6)=KISPGT ILENA( 7)=KISPGP ILENA( 8)=KISPGD ILENA( 9)=KNTTT ILENA(10)=KNTTP ILENA(11)=KNTTD NDTAB=11 CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) NDTAB=NKID CALL ECDIFE(IFSAU,NDTAB,KIDMAT,IFORM) NDTAB=NKMT CALL ECDIFE(IFSAU,NDTAB,KKMMT,IFORM) C Sauvegarde des IMATRI DO 11 I=1,NMATRI IMATRI=IRIGEL(4,I) IF (IMATRI.NE.0) THEN SEGACT IMATRI NBSOUS=LIZAFM(/1) NBME=LIZAFM(/2) ILENA(1)=NBSOUS ILENA(2)=NBME NDTAB=2 CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) NM=4*NBME SEGADJ ITBBM1 DO 111 J=1,NBME J4=(4*J)-3 READ (LISPRI(J),FMT='(2A4)') ITABM1(J4),ITABM1(J4+1) READ (LISDUA(J),FMT='(2A4)') ITABM1(J4+2),ITABM1(J4+3) 111 CONTINUE CALL ECDIFM(IFSAU,NM,ITABM1,IFORM) NDTAB=NBSOUS*NBME CALL ECDIFE(IFSAU,NDTAB,LIZAFM,IFORM) ILENA(1)=KSPGP ILENA(2)=KSPGD NDTAB=2 CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) C Sauvegarde des IZAFM DO 112 K=1,NBME DO 1121 L=1,NBSOUS IZAFM=LIZAFM(L,K) IF (IZAFM.NE.0) THEN SEGACT IZAFM NBEL=AM(/1) NP =AM(/2) MP =AM(/3) ILENA(1)=NBEL ILENA(2)=NP ILENA(3)=MP NDTAB=3 CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) NDTAB=NBEL*NP*MP CALL ECDIFR(IFSAU,NDTAB,AM,IFORM) SEGDES IZAFM ENDIF 1121 CONTINUE 112 CONTINUE SEGDES IMATRI ENDIF 11 CONTINUE C Sauvegarde des MINC IV1=KMINC IF (IV1.NE.0) THEN CALL AJOUN2(ITLAC1,IV1) ENDIF JMINC=IV1 IV1=KMINCP IF (IV1.NE.0) THEN CALL AJOUN2(ITLAC1,IV1) ENDIF JMINCP=IV1 IV1=KMINCD IF (IV1.NE.0) THEN CALL AJOUN2(ITLAC1,IV1) ENDIF JMINCD=IV1 NBMINC=MAX(JMINC,JMINCP,JMINCD) ILENA(1)=NBMINC ILENA(2)=JMINC ILENA(3)=JMINCP ILENA(4)=JMINCD NDTAB=4 CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) DO 12 I=1,NBMINC MINC=ITLAC1.ITLAC(I) SEGACT MINC NPT=MPOS(/1) NBI=MPOS(/2)-1 ILENA(1)=NPT ILENA(2)=NBI NDTAB=2 CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) NM=2*NBI SEGADJ ITBBM1 DO 121 J=1,NBI J2=(2*J)-1 READ (LISINC(J),FMT='(2A4)') ITABM1(J2),ITABM1(J2+1) 121 CONTINUE CALL ECDIFM(IFSAU,NM,ITABM1,IFORM) NDTAB=NPT+1 CALL ECDIFE(IFSAU,NDTAB,NPOS,IFORM) NDTAB=NPT*(NBI+1) CALL ECDIFE(IFSAU,NDTAB,MPOS,IFORM) SEGDES MINC 12 CONTINUE C Sauvegarde des PMORS IV2=KIDMAT(4) IF (IV2.NE.0) THEN CALL AJOUN2(ITLAC2,IV2) ENDIF JMORS=IV2 IV2=KIDMAT(6) IF (IV2.NE.0) THEN CALL AJOUN2(ITLAC2,IV2) ENDIF JMRST=IV2 NBMORS=MAX(JMORS,JMRST) ILENA(1)=NBMORS ILENA(2)=JMORS ILENA(3)=JMRST NDTAB=3 CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) DO 13 I=1,NBMORS PMORS=ITLAC2.ITLAC(I) SEGACT PMORS NTT=IA(/1)-1 NJA=JA(/1) ILENA(1)=NTT ILENA(2)=NJA NDTAB=2 CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) NDTAB=NTT+1 CALL ECDIFE(IFSAU,NDTAB,IA,IFORM) NDTAB=NJA CALL ECDIFE(IFSAU,NDTAB,JA,IFORM) SEGDES PMORS 13 CONTINUE C Sauvegarde des IDMAT (faite avant les IZA C car IDIAG pointe sur un IZA) IV4=KIDMAT(1) IF (IV4.NE.0) THEN CALL AJOUN2(ITLAC4,IV4) ENDIF JDMATP=IV4 IV4=KIDMAT(2) IF (IV4.NE.0) THEN CALL AJOUN2(ITLAC4,IV4) ENDIF JDMATD=IV4 NBIDMA=MAX(JDMATP,JDMATD) ILENA(1)=NBIDMA ILENA(2)=JDMATP ILENA(3)=JDMATD NDTAB=3 CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) C Sauvegarde des IZA IV3=KIDMAT(3) IF (IV3.NE.0) THEN CALL AJOUN2(ITLAC3,IV3) ENDIF JS2B=IV3 IV3=KIDMAT(5) IF (IV3.NE.0) THEN CALL AJOUN2(ITLAC3,IV3) ENDIF JISA=IV3 IV3=KIDMAT(7) IF (IV3.NE.0) THEN CALL AJOUN2(ITLAC3,IV3) ENDIF JIST=IV3 IV3=KKMMT(4) IF (IV3.NE.0) THEN CALL AJOUN2(ITLAC3,IV3) ENDIF JZDU=IV3 IV3=KKMMT(5) IF (IV3.NE.0) THEN CALL AJOUN2(ITLAC3,IV3) ENDIF JZDP=IV3 IV3=KKMMT(6) IF (IV3.NE.0) THEN CALL AJOUN2(ITLAC3,IV3) ENDIF JZFU=IV3 IV3=KKMMT(7) IF (IV3.NE.0) THEN CALL AJOUN2(ITLAC3,IV3) ENDIF JZFP=IV3 NBIZA=MAX(JS2B,JISA,JIST,JZDU,JZDP,JZFU,JZFP) C On sauvegarde les IZA contenus dans les IDMAT DO 16 I=1,NBIDMA IDMAT=ITLAC4.ITLAC(I) SEGACT IDMAT*MOD NBLK=IDESCL(/1) C IDIAG IV3=IDIAG IF (IV3.NE.0) THEN CALL AJOUN2(ITLAC3,IV3) NBIZA=MAX(NBIZA,IV3) ENDIF IDIAG=IV3 C IDESCL DO 161 J=1,NBLK IV3=IDESCL(J) IF (IV3.NE.0) THEN CALL AJOUN2(ITLAC3,IV3) NBIZA=MAX(NBIZA,IV3) ENDIF IDESCL(J)=IV3 161 CONTINUE C IDESCU DO 162 J=1,NBLK IV3=IDESCU(J) IF (IV3.NE.0) THEN CALL AJOUN2(ITLAC3,IV3) NBIZA=MAX(NBIZA,IV3) ENDIF IDESCU(J)=IV3 162 CONTINUE SEGDES IDMAT 16 CONTINUE DO 15 I=1,NBIDMA IDMAT=ITLAC4.ITLAC(I) SEGACT IDMAT NTT =KZA(/1) NPT =NUAN(/1) NBLK=IDESCL(/1) ILENA(1)=NTT ILENA(2)=NPT ILENA(3)=NBLK ILENA(4)=IDIAG NDTAB=4 CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) NDTAB=NTT CALL ECDIFE(IFSAU,NDTAB,KZA,IFORM) NDTAB=2*NTT CALL ECDIFE(IFSAU,NDTAB,NUIA,IFORM) NDTAB=NPT CALL ECDIFE(IFSAU,NDTAB,NUAN,IFORM) NDTAB=NPT CALL ECDIFE(IFSAU,NDTAB,NUNA,IFORM) NDTAB=NBLK CALL ECDIFE(IFSAU,NDTAB,IDESCL,IFORM) NDTAB=NBLK CALL ECDIFE(IFSAU,NDTAB,IDESCU,IFORM) NDTAB=NBLK+1 CALL ECDIFE(IFSAU,NDTAB,NLDBLK,IFORM) SEGDES IDMAT 15 CONTINUE ILENA( 1)=NBIZA ILENA( 2)=JS2B ILENA( 3)=JISA ILENA( 4)=JIST ILENA( 5)=JZDU ILENA( 6)=JZDP ILENA( 7)=JZFU ILENA( 8)=JZFP NDTAB=8 CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) DO 14 I=1,NBIZA IZA=ITLAC3.ITLAC(I) SEGACT IZA NBVA=A(/1) ILENA(1)=NBVA NDTAB=1 CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) NDTAB=NBVA CALL ECDIFR(IFSAU,NDTAB,A,IFORM) SEGDES IZA 14 CONTINUE C Restauration des pointeurs des IZA dans IDMAT DO 17 I=1,NBIDMA IDMAT=ITLAC4.ITLAC(I) SEGACT IDMAT*MOD NBLK=IDESCL(/1) C IDIAG IV3=IDIAG IF (IV3.NE.0) IDIAG=ITLAC3.ITLAC(IV3) C IDESCL DO 171 J=1,NBLK IV3=IDESCL(J) IF (IV3.NE.0) IDESCL(J)=ITLAC3.ITLAC(IV3) 171 CONTINUE C IDESCU DO 172 J=1,NBLK IV3=IDESCU(J) IF (IV3.NE.0) IDESCU(J)=ITLAC3.ITLAC(IV3) 172 CONTINUE SEGDES IDMAT 17 CONTINUE SEGDES MATRIK SEGSUP ITLAC4 SEGSUP ITLAC3 SEGSUP ITLAC2 SEGSUP ITLAC1 1 CONTINUE SEGSUP ITBBM1 * * Normal termination * RETURN * * Format handling * * * Error handling * 9999 CONTINUE WRITE(IOIMP,*) 'An error was detected in subroutine wrmtik' RETURN * * End of subroutine WRMTIK * END