Bugzilla – Attachment 58078 Details for
Bug 134732
gfortran gets ICE and segfaults
Home
|
New
|
Browse
|
Search
|
[?]
|
Reports
|
Requests
|
IDP Log In
|
Forgot Password
the source file mentioned in the report
gesc.f (text/plain), 25.53 KB, created by
Philipp Thomas
on 2005-11-22 11:29:29 UTC
(
hide
)
Description:
the source file mentioned in the report
Filename:
MIME Type:
Creator:
Philipp Thomas
Created:
2005-11-22 11:29:29 UTC
Size:
25.53 KB
patch
obsolete
>C >C $Id: gesc.f,v 1.36 2003/11/24 19:17:20 fred Exp $ >C >C Copyright (C) 2000 >C University Corporation for Atmospheric Research >C All Rights Reserved >C >C This file is free software; you can redistribute it and/or modify >C it under the terms of the GNU General Public License as published >C by the Free Software Foundation; either version 2 of the License, or >C (at your option) any later version. >C >C This software is distributed in the hope that it will be useful, but >C WITHOUT ANY WARRANTY; without even the implied warranty of >C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU >C General Public License for more details. >C >C You should have received a copy of the GNU General Public License >C along with this software; if not, write to the Free Software >C Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 >C USA. >C > SUBROUTINE GESC(FCTID,LIDR,IDR,MLODR,LODR,ODR) >C >C ESCAPE >C > INTEGER EESC > PARAMETER (EESC=11) >C > include 'gkscom.h' > include 'trstat.h' >C > INTEGER FCTID, LIDR, IBUF(46), TBUF(720) > REAL UBUF(26) > CHARACTER*(*) IDR(LIDR),ODR(MLODR) > CHARACTER*137 NAMET > CHARACTER*5 DNAME >C >C Check if GKS is in the proper state. >C > CALL GZCKST(8,EESC,IER) > IF (IER .NE. 0) RETURN >C >C Check if the input data record is of the proper length. >C > LEN1 = LEN(IDR(1)) > IF (LEN1 .NE. 80) THEN > ERS = 1 > CALL GERHND(182,EESC,ERF) > ERS = 0 > RETURN > ENDIF >C >C Check if the function ID is supported. >C > IF (FCTID.LT.0 .AND. (FCTID.LT.-1610 .OR. FCTID.GT.-1350)) THEN > ERS = 1 >C CALL GERHND(180,EESC,ERF) > ERS = 0 > ENDIF >C >C Process legal escape function ID'S: >C -1386 -- Flag for indicating whether the clip rectangle within >C a segment will be transformed as per the segment >C transformation. (1 = transform; 0 = do not transform) >C -1387 -- Temporarily close an NCGM, no matter what the status >C of the file. >C -1388 -- Set/save/restore attributes. >C -1389 -- Reopen an NCGM for appending. >C -1390 -- Returns 'NCAR_GKS0A--VERSION_4.1' in ODR as a check >C to see if the NCAR GKS package is being used. >C -1391 -- Metafile name >C -1392 -- FLASH4 support >C -1393 -- Picture name >C -1394 -- A root for forming segment file names. For example, >C if the root is 'fseg', then the segment names will >C be of the form 'fsegnn' where 'nn' is the segment number. >C -1395 -- Cause a pause in ctrans processing. >C -1396 -- Flag a pause in the X driver. >C -1397 -- Flags whether segments should be deleted or not. >C (0 = save; 1 = delete). >C -1398 -- Maximum number of error messages before abort. >C -1399 -- Flag for GKS clipping (0 = off; 1 = on). >C >C Private escape element only for use by gescape (libncarg_gksC) >C -1450 -- Pass native "C" data to "C" gks drivers. >C Causes an error 180 if called here. >C >C X driver specific escapes (-1400 through -1410): >C -1400 -- Specify the error allowed in matching a requested >C color, expressed as a percentage. The value "0" is >C special--it means you don't care what color is chosen. >C This is only used if -1402 is "shared" >C -1401 -- Used to tell the X driver that the window should have >C its own color map, allowing that window to have 256 >C colors. This has been superceded by -1402. Setting >C this element is equivalant to calling -1402 with "private". >C -1402 -- Used to tell the X driver what color mode to use. This >C is a super-set of -1401 above. The three modes are >C "shared=0", "mixed=2", and "private=1". "private" is the >C same as -1401. It is possible to switch color modes >C during the middle of execution - but only in one direction. >C From "shared" you can switch to either of the other two >C modes. From "mixed" you can switch to "private". If you >C are already using "private" you can not switch. -1400 >C is only used if -1402 is "shared". >C >C PostScript specific escapes: >C >C -1510 -- Flags beginning of segment copy for PS workstations. >C -1511 -- Flags end of segment copy for PS workstations. >C -1512 -- Spacing between fill lines. >C -1513 -- Spacing between hatch lines. >C -1514 -- Maximum size of the stack. >C -1515 -- Maximum number of points in a path. >C -1516 -- Scale factor for nominal linewidth. >C -1517 -- Background fills entire page. >C -1518 -- Line joins. >C -1519 -- Line caps. >C -1520 -- Miter limit. >C -1521 -- Coordinate points for picture positioning. >C -1522 -- Scale factor for PS coordintaes. >C -1523 -- Select CMYK color model or RGB model. >C -1524 -- Flag for suppressing bounding box and background color >C 0 = put out background and bounding box; >C 1 = neither background or bounding box; >C 2 = no background; >C 3 = no bounding box >C -1525 -- Indicate portrait (=0) or landscape (=1) mode for PS. >C -1526 -- Positioning coordinates that can be set between pictures >C or in the middle of a picture. >C >C -1527 -- Produce an NCAR logo. >C -1528 -- Bounding box coordinates for EPS/EPSI files. >C > IF (FCTID .EQ. -1399) THEN >C >C Value to flag if GKS clipping is on. (0 = no; 1 = yes). >C > READ(IDR(1), 501) GKSCLP > ELSE IF (FCTID .EQ. -1398) THEN >C >C Get maximum number of allowable error messages. >C > READ (IDR,500,ERR=135) MXERMG > MXERMG = MAX(0,MXERMG) > RETURN > 135 CONTINUE > ERS = 1 > CALL GERHND(182,EESC,ERF) > ERS = 0 > RETURN > ELSE IF (FCTID .EQ. -1397) THEN >C >C Save segment flag. (1 = delete; 0 = save). >C > READ(IDR(1), 501) SEGDEL > ELSE IF (FCTID .EQ. -1396) THEN >C >C Decode the workstation ID. >C > READ (IDR,501,ERR=130) IWKID > GO TO 140 > 501 FORMAT(I5) > 130 CONTINUE > ERS = 1 > CALL GERHND(182,EESC,ERF) > ERS = 0 > RETURN > 140 CONTINUE > CUFLAG = IWKID > FCODE = 6 > CALL GZROI(0) > IL1 = 1 > IL2 = 1 > ID(1) = FCTID >C >C Send over the data record if there is one (recall that the >C string length of STR is divisible by 80). >C > CONT = 0 > STRL1 = 80 > STRL2 = 80 > STR(1:80) = IDR(1) > CALL GZTOWK > IF (RERR .NE. 0) THEN > ERS = 1 > CALL GERHND(RERR,EESC,ERF) > ERS = 0 > RETURN > ENDIF > CUFLAG = -1 > ELSE IF (FCTID .EQ. -1395) THEN >C >C Put out a CGM MESSAGE element. The message string is in IDR. >C > FCODE = 93 > CONT = 0 > CALL GZROI(0) > STRL1 = 80 > STRL2 = 80 > STR(1:80) = IDR(1) > IL1 = 1 > IL2 = 1 > ID(1) = FCTID > CALL GZTOWK > IF (RERR .NE. 0) THEN > ERS = 1 > CALL GERHND(RERR,EESC,ERF) > ERS = 0 > RETURN > ENDIF > ELSE IF (FCTID .EQ. -1394) THEN >C >C Root for segment file names. >C > GSEGRT = ' ' > GSEGRT = IDR(1) > ELSE IF (FCTID.EQ.-1393) THEN >C >C Picture name. >C > FCODE = 92 > CONT = 0 > CALL GZROI(0) > STRL1 = 80 > STRL2 = 80 > STR(1:80) = IDR(1) > IF (NOPICT .GT. 0) THEN > ERS = 1 > RERR = -108 > CALL GERHND(RERR,EESC,ERF) > ERS = 0 > RETURN > ENDIF > CALL GZTOWK > IF (RERR .NE. 0) THEN > ERS = 1 > CALL GERHND(RERR,EESC,ERF) > ERS = 0 > RETURN > ENDIF > ELSE IF (FCTID .EQ. -1392) THEN >C >C FLASH4 support (segment number is in columns 11-20; segment >C name is in columns 24-80 of IDR(1) (and in IDR(2) if long enough). >C >C >C Check if the input data record is dimensioned properly. >C > IF (LIDR .LE. 0) THEN > ERS = 1 > CALL GERHND(182,EESC,ERF) > ERS = 0 > RETURN > ENDIF >C >C Check if the segment is already in use. >C > READ(IDR(1)(11:20),500) ICSEG > 500 FORMAT(I10) > DO 210 I=1,NUMSEG > IF (SEGS(I) .EQ. ICSEG) THEN > ERS = 1 > CALL GERHND(121,EESC,ERF) > ERS = 0 > RETURN > ENDIF > 210 CONTINUE > NUMSEG = NUMSEG+1 > SEGS(NUMSEG) = ICSEG > SEGNAM(NUMSEG)(1:57) = IDR(1)(24:80) > IF (LIDR .EQ. 2) THEN > SEGNAM(NUMSEG)(58:137) = IDR(2) > ENDIF >C >C Get the connection ID. >C > READ(IDR(1)(21:23),510) IFUNIT > 510 FORMAT(I3) >C >C Determine the segment length. >C > CALL GTNLEN(SEGNAM(NUMSEG),ILEN,IER) > NAMET = ' ' > NAMET(1:ILEN) = SEGNAM(NUMSEG)(1:ILEN) > NAMET(ILEN+1:ILEN+1) = CHAR(0) > CALL G01MIO(8, IFUNIT, NAMET(1:ILEN+1), IDUM1, IDUM2, IER) > IF (IER .NE. 0) THEN > RERR = -105 > GO TO 110 > ENDIF > CALL G01MIO(5,IFUNIT,DNAME,IDUM1,IDUM2,IER) > MRECNM = 1 > MOBFSZ = 1+(11520-1)/I1MACH(5) > 100 CONTINUE > CALL G01MIO(4, IFUNIT, DNAME, TBUF, MOBFSZ, IER) > IF (IER .NE. 0) THEN > IF (IER .EQ. -1) THEN > IF (NUMSEG .GT. 100) THEN > RERR = 120 > GO TO 110 > ELSE > SEGLEN(NUMSEG) = MRECNM-1 > CALL G01MIO(2, IFUNIT, DNAME, TBUF, MOBFSZ, IER) > GO TO 110 > ENDIF > ELSE > RERR = IER > GO TO 110 > ENDIF > ENDIF > MRECNM = MRECNM+1 > GO TO 100 > 110 CONTINUE >C >C Default the segment transformation. >C > DO 30 I=1,2 > DO 40 J=1,3 > SEGT(NUMSEG,I,J) = 0. > 40 CONTINUE > 30 CONTINUE > SEGT(NUMSEG,1,1) = 1. > SEGT(NUMSEG,2,2) = 1. > ELSE IF (FCTID .EQ. -1391) THEN >C >C File name for output metafile. >C > GFNAME = ' ' > DO 250 I=1,LIDR > JLIM = 80 > IF (I .EQ. 4) JLIM = 16 > DO 260 J=1,JLIM > INDX = 80*(I-1)+J > GFNAME(INDX:INDX) = IDR(I)(J:J) > 260 CONTINUE > 250 CONTINUE >C >C Set flag to indicate that the current picture is empty. >C > NOPICT = 0 > ELSE IF (FCTID .EQ. -1390) THEN > ODR(1) = 'NCAR_GKS0A--VERSION_4.0' > ELSE IF (FCTID .EQ. -1389) THEN >C >C Reopen NCGM for appending. >C > GFNAME = ' ' > DO 255 I=1,4 > JLIM = 80 > IF (I .EQ. 4) JLIM = 16 > DO 265 J=1,JLIM > INDX = 80*(I-1)+J > GFNAME(INDX:INDX) = IDR(I+1)(J:J) > 265 CONTINUE > 255 CONTINUE >C >C Set flag to indicate that the current picture is empty (GZREOP >C will reset this to picture not empty if the reopen is done on >C a file in mid picture. >C > NOPICT = 0 > CALL GZREOP(LIDR, IDR, EESC) > IF (RERR .GT. 0) THEN > ERS = 1 > CALL GERHND(RERR,EESC,ERF) > ERS = 0 > RETURN > ENDIF >C >C X11 window escapes. >C > ELSE IF (FCTID.GE.-1410 .AND. FCTID.LE.-1400) THEN >C >C Decode the workstation ID. >C > READ (IDR,501,ERR=150) IWKID > GO TO 160 >C > 150 CONTINUE > ERS = 1 > CALL GERHND(182,EESC,ERF) > ERS = 0 > RETURN >C > 160 CONTINUE >C >C If setting the X Color Model, and IWKID = -1, then the setting >C applies to the next open X workstation. >C > IF (FCTID.EQ.-1402 .AND. IWKID.EQ.-1) THEN > READ(IDR(1)(7:11),501,ERR=150) COLMOD > IF (COLMOD.LT.0 .OR. COLMOD.GT.2) THEN > GOTO 150 > ENDIF > RETURN > ENDIF >C >C Return if not an X11 workstation. >C > CALL GQWKC(IWKID,IER,ICONID,ITYP) > IF (ITYP.NE.GXWE .AND. ITYP.NE.GXWC) THEN > CUFLAG = -1 > RETURN > ENDIF >C > CUFLAG = IWKID > FCODE = 6 > CALL GZROI(0) > IL1 = 1 > IL2 = 1 > ID(1) = FCTID >C >C Send over the data record. >C > IF (LIDR .EQ. 1) THEN > CONT = 0 > STRL1 = 80 > STRL2 = 80 > STR(1:80) = IDR(1) > CALL GZTOWK > IF (RERR .NE. 0) THEN > ERS = 1 > CALL GERHND(RERR,EESC,ERF) > ERS = 0 > RETURN > ENDIF > CUFLAG = -1 > ELSE IF (LIDR .GT. 1) THEN > CONT = 1 > STRL1 = 80*LIDR > STRL2 = 80 > LDRM1 = LIDR-1 > DO 220 I=1,LDRM1 > STR(1:80) = IDR(I) > IF (I .GT. 1) IL2 = 0 > CALL GZTOWK > IF (RERR .NE. 0) THEN > ERS = 1 > CALL GERHND(RERR,EESC,ERF) > ERS = 0 > RETURN > ENDIF > 220 CONTINUE > CONT = 0 > STR(1:80) = IDR(LIDR) > CALL GZTOWK > IF (RERR .NE. 0) THEN > ERS = 1 > CALL GERHND(RERR,EESC,ERF) > ERS = 0 > RETURN > ENDIF > CUFLAG = -1 > ENDIF > ELSE IF (FCTID .EQ. -1388) THEN >C >C Save/restore attributes. >C > READ (IDR(1),501) IOPT > IF (IOPT.EQ.0 .OR. IOPT.EQ.1) THEN > CALL GZUSAT(IOPT,IBUF,UBUF) > ELSE IF (IOPT .EQ. 2) THEN > CALL GZUSAT(IOPT,IBUF(16),UBUF) > IBUF(2) = IBUF(16) > IBUF(3) = IBUF(18) > IBUF(4) = IBUF(19) > IBUF(5) = IBUF(21) > IBUF(6) = IBUF(22) > IBUF(7) = IBUF(24) > IBUF(8) = IBUF(25) > IBUF(9) = IBUF(26) > IBUF(10) = IBUF(27) > IBUF(11) = IBUF(28) > IBUF(12) = IBUF(29) > IBUF(13) = IBUF(31) > IBUF(14) = IBUF(32) > IBUF(15) = IBUF(33) > WRITE(ODR(1),560) (IBUF(LL),LL=2,15) > 560 FORMAT(14I5) > WRITE(ODR(2),540) (UBUF(LL),LL=1,5) > WRITE(ODR(3),550) (UBUF(LL),LL=6,7) > ELSE IF (IOPT .EQ. 3) THEN > READ (IDR(1),530) (IBUF(LL),LL=1,15) > 530 FORMAT(15I5) > READ (IDR(2),540) (UBUF(LL),LL=1,5) > 540 FORMAT(5E16.7) > READ (IDR(3),550) (UBUF(LL),LL=6,7) > 550 FORMAT(2E16.7) > IBUF(16) = IBUF(2) > IBUF(17) = 1 > IBUF(18) = IBUF(3) > IBUF(19) = IBUF(4) > IBUF(20) = 1 > IBUF(21) = IBUF(5) > IBUF(22) = IBUF(6) > IBUF(23) = 1 > IBUF(24) = IBUF(7) > IBUF(25) = IBUF(8) > IBUF(26) = IBUF(9) > IBUF(27) = IBUF(10) > IBUF(28) = IBUF(11) > IBUF(29) = IBUF(12) > IBUF(30) = 1 > IBUF(31) = IBUF(13) > IBUF(32) = IBUF(14) > IBUF(33) = IBUF(15) > IBUF(34) = 1 > IBUF(35) = 1 > IBUF(36) = 1 > IBUF(37) = 1 > IBUF(38) = 1 > IBUF(39) = 1 > IBUF(40) = 1 > IBUF(41) = 1 > IBUF(42) = 1 > IBUF(43) = 1 > IBUF(44) = 1 > IBUF(45) = 1 > IBUF(46) = 1 >C > DO 155 I=1,7 > UBUF(7+I) = UBUF(I) > 155 CONTINUE > UBUF(15) = 1. > UBUF(16) = 1. > UBUF(17) = 0. > UBUF(18) = 0. > CALL GQCLIP(IER,ICD,UBUF(19)) > SCL = 1./SQRT(UBUF(13)*UBUF(13)+UBUF(14)*UBUF(14)) > XP = UBUF(12)*SCL*UBUF(13) > YP = UBUF(12)*SCL*UBUF(14) > XBT = YP > YBT = -XP > CALL GZW2NX(1,XP,XTMP) > CALL GZW2NY(1,YP,YTMP) > CALL GZW2NX(1,0.,ZXTMP) > CALL GZW2NY(1,0.,ZYTMP) > UBUF(23) = XTMP-ZXTMP > UBUF(24) = YTMP-ZYTMP > CALL GZW2NX(1,XBT,XTMP) > CALL GZW2NY(1,YBT,YTMP) > UBUF(25) = XTMP-ZXTMP > UBUF(26) = YTMP-ZYTMP >C > CALL GZUSAT(3,IBUF(16),UBUF(8)) > ENDIF > ELSE IF (FCTID .EQ. -1387) THEN >C >C Terminate an NCGM without putting out an END PICTURE or an >C END METAFILE. This is to be used as a way of suspending >C output to a metafile for possible reopening with GZREOP. >C > READ (IDR(1),501) IWKID >C >C Check that GKS is in the proper state. >C > CALL GZCKST(7,EESC,IER) > IF (IER .NE. 0) RETURN >C >C Check if the workstation identifier is valid. >C > CALL GZCKWK(20,EESC,IWKID,IDUM,IER) > IF (IER .NE. 0) RETURN >C >C Check if the specified workstation is open. >C > CALL GZCKWK(25,EESC,IWKID,IDUM,IER) > IF (IER .NE. 0) RETURN >C >C Check if the workstation is currently active. >C > CALL GZCKWK(29,EESC,IWKID,IDUM,IER) > IF (IER .NE. 0) RETURN >C >C Invoke the workstation interface (do this before flagging >C the workstation as closed). >C >C Determine the workstation type. >C > DO 230 I=1,NOPWK > IF (SOPWK(I) .EQ. IWKID) THEN > NWKTP = SWKTP(I) > GO TO 240 > ENDIF > 230 CONTINUE > 240 CONTINUE >C > IF (NWKTP .NE. GCGM) THEN > ERS = 1 > CALL GERHND(-400,EESC,ERF) > ERS = 0 > ENDIF >C >C Invoke the workstation interface. Set CUFLAG to indicate that >C the interface call should go only to the specifically designated >C workstation. > > CUFLAG = IWKID > FCODE = -5 > CONT = 0 > CALL GZROI(0) > IL1 = 1 > IL2 = 1 > ID(1) = IWKID > CALL GZTOWK > IF (RERR.NE.0) THEN > ERS = 1 > CALL GERHND(RERR,EESC,ERF) > ERS = 0 > ENDIF > CUFLAG = -1 >C >C Remove the workstation identifier from the set of open >C workstations in the GKS state list and delete it from >C the X workstation list. >C > IF (NOPWK .EQ. 1) THEN > SOPWK(1) = -1 > SWKTP(1) = -1 > LXWKID(1) = -1 > NOPWK = 0 > ELSE > DO 201 I=1,NOPWK > IF (SOPWK(I) .EQ. IWKID) THEN > IF (I .EQ. NOPWK) THEN > SOPWK(NOPWK) = -1 > SWKTP(NOPWK) = -1 > LXWKID(I) = -1 > NOPWK = NOPWK-1 > ELSE > NM1 = NOPWK-1 > DO 202 J=I,NM1 > SOPWK(J) = SOPWK(J+1) > SWKTP(J) = SWKTP(J+1) > LXWKID(J) = LXWKID(J+1) > 202 CONTINUE > SOPWK(NOPWK) = -1 > SWKTP(NOPWK) = -1 > LXWKID(NOPWK) = -1 > NOPWK = NOPWK-1 > ENDIF > ENDIF > 201 CONTINUE > ENDIF >C >C Set GKS to state GKOP if no workstations remain open. >C > IF (SOPWK(1) .EQ. -1) THEN > OPS = GGKOP > ENDIF > ELSE IF (FCTID .EQ. -1386) THEN > READ (IDR,501,ERR=137) IGSGCP > GO TO 136 > 137 CONTINUE > ERS = 1 > CALL GERHND(182,EESC,ERF) > ERS = 0 > RETURN > 136 CONTINUE >C >C >C PostScript and PDF escapes. >C > ELSE IF (FCTID.GE.-1530 .AND. FCTID.LE.-1510) THEN >C >C Decode the workstation ID. >C > READ (IDR,501,ERR=350) IWKID > GO TO 360 >C > 350 CONTINUE > ERS = 1 > CALL GERHND(182,EESC,ERF) > ERS = 0 > RETURN >C > 360 CONTINUE > CUFLAG = IWKID >C >C If setting coordinates for positioning on the page, store them >C for use with the next OPEN WORKSTATION. This call can be made >C with no workstations open. >C > IF (FCTID .EQ. -1521) THEN > CUFLAG = -1 > READ(IDR(1)( 2:10),520) CLLX > READ(IDR(1)(12:20),520) CLLY > READ(IDR(1)(22:30),520) CURX > READ(IDR(1)(32:40),520) CURY > 520 FORMAT(I9) > ENDIF >C >C Coordinate scale factor for next PostScript workstation opened. >C > IF (FCTID .EQ. -1522) THEN > CUFLAG = -1 > READ(IDR(1)(1:5),501) CPSCL > RETURN > ENDIF >C >C Color model selection (1=RGB, 0=CMYK). >C > IF (FCTID .EQ. -1523) THEN > READ(IDR(1)(1: 5),501) CCMDL > ENDIF >C >C Suppress flag for background color and/or bounding box. >C > IF (FCTID .EQ. -1524) THEN > READ(IDR(1)(1:5),501) CSUPR > RETURN > ENDIF >C >C Portrait/landscape flag for PS and PDF output. >C > IF (FCTID .EQ. -1525) THEN > READ(IDR(1)(1:5),501,ERR=146) IWKID > GO TO 166 > 146 CONTINUE > ERS = 1 > CALL GERHND(182,EESC,ERF) > ERS = 0 > RETURN > 166 CONTINUE > CUFLAG = IWKID > READ(IDR(1)(6:10),501) CPTLD > ENDIF >C >C Positioning coordinates for PS that can be set between pictures >C or in the middle of a picture. >C > IF (FCTID .EQ. -1526) THEN > READ(IDR(1)(1:5),501,ERR=145) IWKID > GO TO 165 > 145 CONTINUE > ERS = 1 > CALL GERHND(182,EESC,ERF) > ERS = 0 > RETURN > 165 CONTINUE > CUFLAG = IWKID > ENDIF >C >C Return if not a PostScript or PDF workstation, unless FCTID = -1521 >C or FCTID = -1525, or FCTID = -1526. >C > CALL GQWKC(IWKID,IER,ICONID,ITYP) > IF (ITYP.NE.GPDFP .AND. ITYP.NE.GPDFL) THEN > IF (ITYP.GT.GPSMAX .OR. ITYP.LT.GPSMIN) THEN > CUFLAG = -1 > IF (FCTID.NE.-1521 .AND. FCTID.NE.-1525 .AND. > + FCTID.NE.-1526) RETURN > ENDIF > ENDIF >C > 167 CONTINUE > FCODE = 6 > CALL GZROI(0) > IL1 = 1 > IL2 = 1 > ID(1) = FCTID >C >C Send over the data record. >C > IF (LIDR .EQ. 1) THEN > CONT = 0 > STRL1 = 80 > STRL2 = 80 > STR(1:80) = IDR(1) > CALL GZTOWK > IF (RERR .NE. 0) THEN > ERS = 1 > CALL GERHND(RERR,EESC,ERF) > ERS = 0 > RETURN > ENDIF > CUFLAG = -1 > ELSE IF (LIDR .GT. 1) THEN > CONT = 1 > STRL1 = 80*LIDR > STRL2 = 80 > LDRM1 = LIDR-1 > DO 320 I=1,LDRM1 > STR(1:80) = IDR(I) > IF (I .GT. 1) IL2 = 0 > CALL GZTOWK > IF (RERR .NE. 0) THEN > ERS = 1 > CALL GERHND(RERR,EESC,ERF) > ERS = 0 > RETURN > ENDIF > 320 CONTINUE > CONT = 0 > STR(1:80) = IDR(LIDR) > CALL GZTOWK > IF (RERR .NE. 0) THEN > ERS = 1 > CALL GERHND(RERR,EESC,ERF) > ERS = 0 > RETURN > ENDIF > CUFLAG = -1 > ENDIF >C >C Positioning coordinates for PS that can be set between pictures >C or in the middle of a picture. >C > IF (FCTID .EQ. -1528) THEN > READ(IDR(1)(1:5),501,ERR=176) IWKID > GO TO 175 > 176 CONTINUE > ERS = 1 > CALL GERHND(182,EESC,ERF) > ERS = 0 > RETURN > 175 CONTINUE > CUFLAG = IWKID > ENDIF >C >C Return if not a PostScript or PDF workstation, unless FCTID = -1521 >C or FCTID = -1525, or FCTID = -1526, or FCTID = -1528. >C > CALL GQWKC(IWKID,IER,ICONID,ITYP) > IF (ITYP.NE.GPDFP .AND. ITYP.NE.GPDFL) THEN > IF (ITYP.GT.GPSMAX .OR. ITYP.LT.GPSMIN) THEN > CUFLAG = -1 > IF (FCTID.NE.-1521 .AND. FCTID.NE.-1525 .AND. > + FCTID.NE.-1526 .AND. FCTID.NE.-1528) RETURN > ENDIF > ENDIF >C > FCODE = 6 > CALL GZROI(0) > IL1 = 1 > IL2 = 1 > ID(1) = FCTID >C >C Send over the data record. >C > IF (LIDR .EQ. 1) THEN > CONT = 0 > STRL1 = 80 > STRL2 = 80 > STR(1:80) = IDR(1) > CALL GZTOWK > IF (RERR .NE. 0) THEN > ERS = 1 > CALL GERHND(RERR,EESC,ERF) > ERS = 0 > RETURN > ENDIF > CUFLAG = -1 > ELSE IF (LIDR .GT. 1) THEN > CONT = 1 > STRL1 = 80*LIDR > STRL2 = 80 > LDRM1 = LIDR-1 > DO 321 I=1,LDRM1 > STR(1:80) = IDR(I) > IF (I .GT. 1) IL2 = 0 > CALL GZTOWK > IF (RERR .NE. 0) THEN > ERS = 1 > CALL GERHND(RERR,EESC,ERF) > ERS = 0 > RETURN > ENDIF > 321 CONTINUE > CONT = 0 > STR(1:80) = IDR(LIDR) > CALL GZTOWK > IF (RERR .NE. 0) THEN > ERS = 1 > CALL GERHND(RERR,EESC,ERF) > ERS = 0 > RETURN > ENDIF > CUFLAG = -1 > ENDIF >C >C Sending "native" C data to a C driver (NOT FROM FORTRAN!) >C > ELSE IF (FCTID .EQ. -1450) THEN > ERS = 1 > CALL GERHND(180,EESC,ERF) > ERS = 0 > RETURN > ELSE >C >C Send ESCAPE element. >C > FCODE = 6 > CALL GZROI(0) > IL1 = 1 > IL2 = 1 > RL1 = 0 > RL2 = 0 > IC1 = 0 > IC2 = 0 > ID(1) = FCTID >C >C Send over the data record if there is one (recall that the >C string length of STR is divisible by 80). >C > IF (LIDR .GE. 1) THEN > IF (LIDR .EQ. 1) THEN > CONT = 0 > STRL1 = 80 > STRL2 = 80 > STR(1:80) = IDR(1) > CALL GZTOWK > IF (RERR .NE. 0) THEN > ERS = 1 > CALL GERHND(RERR,EESC,ERF) > ERS = 0 > RETURN > ENDIF > ELSE >C >C Send over the data record 80 characters at a time. >C > CONT = 1 > STRL1 = 80*LIDR > STRL2 = 80 > LDRM1 = LIDR-1 > DO 200 I=1,LDRM1 > STR(1:80) = IDR(I) > IF (I .GT. 1) IL2 = 0 > CALL GZTOWK > IF (RERR .NE. 0) THEN > ERS = 1 > CALL GERHND(RERR,EESC,ERF) > ERS = 0 > RETURN > ENDIF > 200 CONTINUE > CONT = 0 > STR(1:80) = IDR(LIDR) > CALL GZTOWK > IF (RERR .NE. 0) THEN > ERS = 1 > CALL GERHND(RERR,EESC,ERF) > ERS = 0 > RETURN > ENDIF > ENDIF > ELSE > CONT = 0 > CALL GZTOWK > IF (RERR .NE. 0) THEN > ERS = 1 > CALL GERHND(RERR,EESC,ERF) > ERS = 0 > RETURN > ENDIF > ENDIF > ENDIF >C > RETURN > END
You cannot view the attachment while viewing its details because your browser does not support IFRAMEs.
View the attachment on a separate page
.
Actions:
View
Attachments on
bug 134732
: 58078 |
58097
|
58098