Philippe 23/02/2016: lfi2cdf: modif for JPHEXT/=1
[MNH-git_open_source-lfs.git] / LIBTOOLS / tools / diachro / src / POS / wtstr.f
1 C
2 C $Id$
3 C
4       SUBROUTINE WTSTR (PX,PY,CH,IS,IO,IC)
5 C
6 C WTSTR is called to draw a character string in a specified position.
7 C
8 C PX and PY specify, in user coordinates, the position of a point
9 C relative to which a character string is to be positioned.
10 C
11 C CH is the character string to be written.
12 C
13 C IS is the desired size of the characters to be used, stated as a
14 C character width in the plotter coordinate system.  The values 0, 1,
15 C 2, and 3 mean 8, 12, 16, and 24, respectively.
16 C
17 C IO is the desired orientation angle, in degrees counterclockwise from
18 C a horizontal vector pointing to the right.
19 C
20 C IC specifies the desired type of centering.  A negative value puts
21 C (PX,PY) in the center of the left end of the character string, a zero
22 C puts (PX,PY) in the center of the whole string, and a positive value
23 C puts (PX,PY) in the center of the right end of the character string.
24 C
25       CHARACTER*(*) CH
26 C
27 C Define arrays in which to save the current viewport and window.
28 C
29       DIMENSION VP(4),WD(4)
30 C
31 C Check for an uncleared prior error.
32 C
33       IF (ICFELL('WTSTR - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
34 C
35 C Flush the pen-move buffer.
36 C
37       CALL PLOTIF (0.,0.,2)
38       IF (ICFELL('WTSTR',2).NE.0) RETURN
39 C
40 C Compute the coordinates of (PX,PY) in the fractional coordinate
41 C system (normalized device coordinates).
42 C
43       XN=CUFX(PX)
44       IF (ICFELL('WTSTR',3).NE.0) RETURN
45       YN=CUFY(PY)
46       IF (ICFELL('WTSTR',4).NE.0) RETURN
47 c      print *,' XN,YN ',XN,YN
48 C
49 C Save the current window and, if necessary, redefine it so that we can
50 C use normalized device coordinates.
51 C
52       CALL GQCNTN (IE,NT)
53       IF (IE.NE.0) THEN
54         CALL SETER ('WTSTR - ERROR EXIT FROM GQCNTN',5,1)
55         RETURN
56       END IF
57       IF (NT.NE.0) THEN
58         CALL GQNT (NT,IE,WD,VP)
59 c       print *,' **wtrst WD PX PY ',WD,PX,PY
60         IF (IE.NE.0) THEN
61           CALL SETER ('WTSTR - ERROR EXIT FROM GQNT',6,1)
62           RETURN
63         END IF
64         CALL GSWN (NT,VP(1),VP(2),VP(3),VP(4))
65       END IF
66 C
67 C Save current character height, text path, character up vector, and
68 C text alignment.
69 C
70       CALL GQCHH (IE,OS)
71       IF (IE.NE.0) THEN
72         CALL SETER ('WTSTR - ERROR EXIT FROM GQCHH',7,1)
73         RETURN
74       END IF
75       CALL GQTXP (IE,IP)
76       IF (IE.NE.0) THEN
77         CALL SETER ('WTSTR - ERROR EXIT FROM GQTXP',8,1)
78         RETURN
79       END IF
80       CALL GQCHUP (IE,UX,UY)
81       IF (IE.NE.0) THEN
82         CALL SETER ('WTSTR - ERROR EXIT FROM GQCHUP',9,1)
83         RETURN
84       END IF
85       CALL GQTXAL (IE,IX,IY)
86       IF (IE.NE.0) THEN
87         CALL SETER ('WTSTR - ERROR EXIT FROM GQTXAL',10,1)
88         RETURN
89       END IF
90 C
91 C Define the character height.  (The final scale factor is derived from
92 C the default font.)
93 C
94       CALL GETUSV ('YF',MY)
95       IF (ICFELL('WTSTR',11).NE.0) RETURN
96       YS=FLOAT(2**MY)
97       IF (IS.GE.0.AND.IS.LE.3) THEN
98         CS=FLOAT(8+4*IS+4*(IS/3))/YS
99       ELSE
100         CS=AMIN1(FLOAT(IS),YS)/YS
101       ENDIF
102 C
103 C     CS=CS*1.0
104 C
105       CALL GSCHH(CS)
106 C
107 C Define the text path.
108 C
109       CALL GSTXP (0)
110 C
111 C Define the character up vector.
112 C
113       JO=MOD(IO,360)
114       IF (JO.EQ.0) THEN
115         CALL GSCHUP (0.,1.)
116       ELSE IF (JO.EQ.90) THEN
117         CALL GSCHUP (-1.,0.)
118       ELSE IF (JO.EQ.180) THEN
119         CALL GSCHUP (0.,-1.)
120       ELSE IF (JO.EQ.270) THEN
121         CALL GSCHUP (1.,0.)
122       ELSE IF (JO.GT.0.AND.JO.LT.180) THEN
123         CALL GSCHUP (-1.,1./TAN(FLOAT(JO)*3.1415926/180.))
124       ELSE
125         CALL GSCHUP (1.,-1./TAN(FLOAT(JO)*3.1415926/180.))
126       ENDIF
127 C
128 C Define the text alignment.
129 C
130       CALL GSTXAL (MAX(-1,MIN(+1,IC))+2,3)
131 C
132 C Plot the characters.
133 C
134       IF(LEN_TRIM(CH) < LEN(CH))THEN
135       CH=ADJUSTL(CH)
136       ENDIF
137 c     print *,' **wts... AV GTX XN,YN,CH ',XN,YN,CH
138       CALL GTX (XN,YN,CH)
139 c     print *,' **wts... AP GTX '
140 C
141 C Restore the original text attributes.
142 C
143       CALL GSCHH (OS)
144       CALL GSTXP (IP)
145       CALL GSCHUP (UX,UY)
146       CALL GSTXAL (IX,IY)
147 C
148 C Restore the window definition.
149 C
150       IF (NT.NE.0) THEN
151         CALL GSWN (NT,WD(1),WD(2),WD(3),WD(4))
152       END IF
153 C
154 C Update the pen position.
155 C
156 c       print *,' **wtrstortie '
157       IF(PX < WD(1) .OR. PX > WD(2) .OR. PY < WD(3) .OR.
158      1PY > WD(4))THEN
159 c      print *,' **wtrst WD,PX,PY ',WD,PX,PY
160       IF(PX < WD(1))PX=WD(1)
161       IF(PX > WD(2))PX=WD(2)
162       IF(PY < WD(3))PY=WD(3)
163       IF(PY > WD(4))PY=WD(4)
164       ENDIF
165       CALL FRSTPT (PX,PY)
166 c       print *,' **wtrstortie b'
167       IF (ICFELL('WTSTR',12).NE.0) RETURN
168 C
169 C Done.
170 C
171 c       print *,' **wtrstortie av return '
172       RETURN
173 C
174       END