← Back to branch summary

~ubuntu-branches/debian/jessie/eso-midas/jessie

« back to all changes in this revision

Viewing changes to prim/table/libsrc/tdcopy.for

  • Committer: Package Import Robot
  • Author(s): Ole Streicher
  • Date: 2014-04-22 14:44:58 UTC
  • Revision ID: package-import@ubuntu.com-20140422144458-okiwi1assxkkiz39
Tags: upstream-13.09pl1.2+dfsg
Import upstream version 13.09pl1.2+dfsg

Show diffs side-by-side

added added

removed removed

Lines of Context:
prim/table/libsrc/tdcopy.for
 
1
C===========================================================================
 
2
C Copyright (C) 1995-2010 European Southern Observatory (ESO)
 
3
C
 
4
C This program is free software; you can redistribute it and/or 
 
5
C modify it under the terms of the GNU General Public License as 
 
6
C published by the Free Software Foundation; either version 2 of 
 
7
C the License, or (at your option) any later version.
 
8
C
 
9
C This program is distributed in the hope that it will be useful,
 
10
C but WITHOUT ANY WARRANTY; without even the implied warranty of
 
11
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
12
C GNU General Public License for more details.
 
13
C
 
14
C You should have received a copy of the GNU General Public 
 
15
C License along with this program; if not, write to the Free 
 
16
C Software Foundation, Inc., 675 Massachusetts Ave, Cambridge, 
 
17
C MA 02139, USA.
 
18
C
 
19
C Correspondence concerning ESO-MIDAS should be addressed as follows:
 
20
C       Internet e-mail: midas@eso.org
 
21
C       Postal address: European Southern Observatory
 
22
C                       Data Management Division 
 
23
C                       Karl-Schwarzschild-Strasse 2
 
24
C                       D 85748 Garching bei Muenchen 
 
25
C                       GERMANY
 
26
C===========================================================================
 
27
C
 
28
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
29
C
 
30
C.LANGUAGE: F77+ESOext
 
31
C
 
32
C.AUTHOR: J.D.PONZ
 
33
C
 
34
C
 
35
C.IDENTIFICATION        TDCOPY.FOR
 
36
C.KEYWORDS           TABLE, APPLICATIONS
 
37
C.ENVIRONMENT  MIDAS
 
38
C.PURPOSE
 
39
C  UTILITIES USED INTERNALLY IN THE PACKAGE TO COPY SCALARS, VECTORS AND
 
40
C  COLUMNS
 
41
C
 
42
C.VERSION: 1.0  ESO-FORTRAN Conversion, AA  19:37 - 11 DEC 1987
 
43
C
 
44
C 100923        last modif
 
45
C 
 
46
C------------------------------------------------------------------
 
47
C
 
48
      SUBROUTINE TDCPVV(INPUT,OUTPUT,N)
 
49
C
 
50
C COPY INPUT(N) INTO OUTPUT(N)
 
51
C INTERNAL ROUTINE TO BE USED IN THE MAPPING CONTEXT
 
52
      IMPLICIT NONE
 
53
C
 
54
      INTEGER  N
 
55
      REAL     INPUT(N)
 
56
      REAL     OUTPUT(N)
 
57
      INTEGER  I
 
58
C
 
59
C
 
60
      DO 10 I = 1,N
 
61
          OUTPUT(I) = INPUT(I)
 
62
   10 CONTINUE
 
63
      RETURN
 
64
 
 
65
      END
 
66
 
 
67
      SUBROUTINE TDCPSV(INPUT,OUTPUT,N,I)
 
68
C
 
69
C COPY THE SINGLE PRECISION VALUE INPUT(I) INTO THE ARRAY OUTPUT(N)
 
70
C INTERNAL ROUTINE TO BE USED IN THE MAPPING CONTEXT
 
71
C
 
72
C      IMPLICIT NONE
 
73
      INTEGER I,J,N
 
74
      REAL INPUT(I),OUTPUT(N)
 
75
 
 
76
      DO 10 J = 1,N
 
77
          OUTPUT(J) = INPUT(I)
 
78
   10 CONTINUE
 
79
      RETURN
 
80
 
 
81
      END
 
82
 
 
83
      SUBROUTINE TDCPDV(INPUT,OUTPUT,N,I)
 
84
C
 
85
C COPY THE DOUBLE PRECISION VALUE INPUT(I) INTO THE ARRAY OUTPUT(N)
 
86
C INTERNAL ROUTINE TO BE USED IN THE MAPPING CONTEXT
 
87
C
 
88
C      IMPLICIT NONE
 
89
      INTEGER I,J,N
 
90
      DOUBLE PRECISION INPUT(I),OUTPUT(N)
 
91
 
 
92
      DO 10 J = 1,N
 
93
          OUTPUT(J) = INPUT(I)
 
94
   10 CONTINUE
 
95
      RETURN
 
96
 
 
97
      END
 
98
 
 
99
      SUBROUTINE TDCPSS(INPUT,OUTPUT,I,J)
 
100
C
 
101
C COPY INPUT(I) INTO OUTPUT(J)
 
102
C INTERNAL ROUTINE TO BE USED IN THE MAPPING CONTEXT
 
103
C
 
104
C      IMPLICIT NONE
 
105
 
 
106
      INTEGER I,J
 
107
      REAL INPUT(I),OUTPUT(J)
 
108
 
 
109
      OUTPUT(J) = INPUT(I)
 
110
      RETURN
 
111
 
 
112
      END
 
113
 
 
114
      SUBROUTINE TDCPDD(INPUT,OUTPUT,I,J)
 
115
C
 
116
C COPY INPUT(I) INTO OUTPUT(J)
 
117
C      IMPLICIT NONE
 
118
C INTERNAL ROUTINE TO BE USED IN THE MAPPING CONTEXT
 
119
C
 
120
 
 
121
      INTEGER I,J
 
122
      DOUBLE PRECISION INPUT(I),OUTPUT(J)
 
123
 
 
124
      OUTPUT(J) = INPUT(I)
 
125
      RETURN
 
126
 
 
127
      END
 
128
 
 
129
      SUBROUTINE TDCCRR(MASK,INPUT,OUTPUT,N)
 
130
C
 
131
C  COPY REAL ARRAY ACCORDING TO MASK.
 
132
C      IMPLICIT NONE
 
133
C SKIP OVER NON SELECTED VALUES
 
134
C
 
135
      INTEGER I,N
 
136
      REAL MASK(N),INPUT(N),OUTPUT(N)
 
137
C
 
138
      REAL TBLSEL
 
139
      DOUBLE PRECISION TDTRUE, TDFALS
 
140
C
 
141
C ... GET SELECTION VALUE
 
142
C
 
143
      CALL TBMCON(TBLSEL, TDTRUE, TDFALS)
 
144
C
 
145
C ... ITERATION
 
146
C
 
147
      DO 10 I = 1,N
 
148
          IF (MASK(I).EQ.TBLSEL) OUTPUT(I) = INPUT(I)
 
149
   10 CONTINUE
 
150
      RETURN
 
151
 
 
152
      END
 
153
 
 
154
      SUBROUTINE TDCCR1(MASK,INPUT,OUTPUT,N,NT)
 
155
C
 
156
C  COPY REAL ARRAY ACCORDING TO MASK.
 
157
C DO NOT SKIP OVER NON SELECTED VALUES
 
158
C
 
159
C      IMPLICIT NONE
 
160
      INTEGER I,N,NT,NNT
 
161
      REAL MASK(N),INPUT(N),OUTPUT(N)
 
162
C
 
163
      REAL TBLSEL
 
164
      DOUBLE PRECISION TDTRUE, TDFALS
 
165
C
 
166
C ... GET SELECTION VALUE
 
167
C
 
168
      CALL TBMCON(TBLSEL, TDTRUE, TDFALS)
 
169
C
 
170
C ... ITERATION
 
171
C
 
172
      NNT    = 0
 
173
      DO 10 I = 1,N
 
174
          IF (MASK(I).EQ.TBLSEL) THEN
 
175
              NNT    = NNT + 1
 
176
              OUTPUT(NNT) = INPUT(I)
 
177
          END IF
 
178
 
 
179
   10 CONTINUE
 
180
      NT     = NNT
 
181
      RETURN
 
182
 
 
183
      END
 
184
 
 
185
      SUBROUTINE TDCCR2(MASK,INPUT,OUTPUT,N,NT)
 
186
C
 
187
C  COPY REAL ARRAY ACCORDING TO MASK.
 
188
C DO NOT SKIP OVER NON SELECTED VALUES
 
189
C       DO NOT COPY THE NULL VALUES
 
190
C
 
191
C      IMPLICIT NONE
 
192
      INTEGER I,N,NT,NNT
 
193
      REAL MASK(N),INPUT(N),OUTPUT(N)
 
194
C
 
195
      INTEGER TINULL
 
196
      REAL    TBLSEL, TRNULL
 
197
      DOUBLE PRECISION TDTRUE, TDFALS, TDNULL
 
198
C
 
199
C ... GET MACHINE DEPENDENT VALUES
 
200
C
 
201
      CALL TBMCON(TBLSEL, TDTRUE, TDFALS)
 
202
      CALL TBMNUL(TINULL, TRNULL, TDNULL)
 
203
C
 
204
C ... ITERATION
 
205
C
 
206
      NNT    = 0
 
207
      DO 10 I = 1,N
 
208
          IF (MASK(I).EQ.TBLSEL .AND. INPUT(I).NE.TRNULL) THEN
 
209
              NNT    = NNT + 1
 
210
              OUTPUT(NNT) = INPUT(I)
 
211
          END IF
 
212
 
 
213
   10 CONTINUE
 
214
      NT     = NNT
 
215
      RETURN
 
216
 
 
217
      END
 
218
 
 
219
      SUBROUTINE TDCCDD(MASK,INPUT,OUTPUT,N)
 
220
C
 
221
C  COPY DOUBLE PRECISION ARRAY ACCORDING TO MASK.
 
222
C SKIP OVER NON SELECTED VALUES
 
223
C
 
224
C      IMPLICIT NONE
 
225
      INTEGER I,N
 
226
      REAL MASK(N)
 
227
      DOUBLE PRECISION INPUT(N),OUTPUT(N)
 
228
C
 
229
      REAL    TBLSEL
 
230
      DOUBLE PRECISION TDTRUE, TDFALS
 
231
C
 
232
C ... GET MACHINE DEPENDENT VALUES
 
233
C
 
234
      CALL TBMCON(TBLSEL, TDTRUE, TDFALS)
 
235
C
 
236
C ... ITERATION
 
237
C
 
238
      DO 10 I = 1,N
 
239
          IF (MASK(I).EQ.TBLSEL) OUTPUT(I) = INPUT(I)
 
240
   10 CONTINUE
 
241
      RETURN
 
242
 
 
243
      END
 
244
 
 
245
      SUBROUTINE TDCCD1(MASK,INPUT,OUTPUT,N,NT)
 
246
C
 
247
C  COPY REAL ARRAY ACCORDING TO MASK.
 
248
C DO NOT SKIP OVER NON SELECTED VALUES
 
249
C
 
250
C      IMPLICIT NONE
 
251
      INTEGER I,N,NT,NNT
 
252
      REAL MASK(N)
 
253
      DOUBLE PRECISION INPUT(N),OUTPUT(N)
 
254
C
 
255
      REAL    TBLSEL
 
256
      DOUBLE PRECISION TDTRUE, TDFALS
 
257
C
 
258
C ... GET MACHINE DEPENDENT VALUES
 
259
C
 
260
      CALL TBMCON(TBLSEL, TDTRUE, TDFALS)
 
261
C
 
262
C ... ITERATION
 
263
C
 
264
      NNT    = 0
 
265
      DO 10 I = 1,N
 
266
          IF (MASK(I).EQ.TBLSEL) THEN
 
267
              NNT    = NNT + 1
 
268
              OUTPUT(NNT) = INPUT(I)
 
269
          END IF
 
270
 
 
271
   10 CONTINUE
 
272
      NT     = NNT
 
273
      RETURN
 
274
 
 
275
      END
 
276
 
 
277
      SUBROUTINE TDCCD2(MASK,INPUT,OUTPUT,N,NT)
 
278
C
 
279
C  COPY REAL ARRAY ACCORDING TO MASK.
 
280
C DO NOT SKIP OVER NON SELECTED VALUES
 
281
C       DO NOT COPY NULL VALUES
 
282
C
 
283
C      IMPLICIT NONE
 
284
      INTEGER I,N,NT,NNT
 
285
      REAL MASK(N)
 
286
      DOUBLE PRECISION INPUT(N),OUTPUT(N)
 
287
C
 
288
      INTEGER TINULL
 
289
      REAL    TBLSEL, TRNULL
 
290
      DOUBLE PRECISION TDTRUE, TDFALS, TDNULL
 
291
C
 
292
C ... GET MACHINE DEPENDENT VALUES
 
293
C
 
294
      CALL TBMCON(TBLSEL, TDTRUE, TDFALS)
 
295
      CALL TBMNUL(TINULL, TRNULL, TDNULL)
 
296
C
 
297
C ... ITERATION
 
298
C
 
299
      NNT    = 0
 
300
      DO 10 I = 1,N
 
301
          IF (MASK(I).EQ.TBLSEL .AND. INPUT(I).NE.TDNULL) THEN
 
302
              NNT    = NNT + 1
 
303
              OUTPUT(NNT) = INPUT(I)
 
304
          END IF
 
305
 
 
306
   10 CONTINUE
 
307
      NT     = NNT
 
308
      RETURN
 
309
 
 
310
      END
 
311
 
 
312
      SUBROUTINE TDCCWW(MASK,INPUT,OUTPUT,N,NW)
 
313
C
 
314
C  COPY BYTE ARRAY ACCORDING TO MASK.
 
315
C SKIP OVER NON SELECTED VALUES
 
316
C
 
317
C      IMPLICIT NONE
 
318
      INTEGER I,J,N,NW
 
319
      REAL MASK(N)
 
320
      REAL INPUT(NW,N),OUTPUT(NW,N)
 
321
C
 
322
      REAL    TBLSEL
 
323
      DOUBLE PRECISION TDTRUE, TDFALS
 
324
C
 
325
C ... GET MACHINE DEPENDENT VALUES
 
326
C
 
327
      CALL TBMCON(TBLSEL, TDTRUE, TDFALS)
 
328
C
 
329
C ... ITERATION
 
330
C
 
331
      DO 20 I = 1,N
 
332
          IF (MASK(I).EQ.TBLSEL) THEN
 
333
              DO 10 J = 1,NW
 
334
                  OUTPUT(J,I) = INPUT(J,I)
 
335
   10         CONTINUE
 
336
          END IF
 
337
 
 
338
   20 CONTINUE
 
339
      RETURN
 
340
 
 
341
      END
 
342
 
 
343
      SUBROUTINE TDCCW1(MASK,INPUT,OUTPUT,N,NW,NT)
 
344
C
 
345
C  COPY ARRAY ACCORDING TO MASK.
 
346
C DO NOT SKIP OVER NON SELECTED VALUES
 
347
C
 
348
      INTEGER I,J,N,NW,NT,NNT
 
349
      REAL MASK(N)
 
350
      REAL INPUT(NW,N),OUTPUT(NW,N)
 
351
C
 
352
      REAL    TBLSEL
 
353
      DOUBLE PRECISION TDTRUE, TDFALS
 
354
C
 
355
C ... GET MACHINE DEPENDENT VALUES
 
356
C
 
357
      CALL TBMCON(TBLSEL, TDTRUE, TDFALS)
 
358
C
 
359
C ... ITERATION
 
360
C
 
361
      NNT    = 0
 
362
      DO 20 I = 1,N
 
363
          IF (MASK(I).EQ.TBLSEL) THEN
 
364
              NNT    = NNT + 1
 
365
              DO 10 J = 1,NW
 
366
                  OUTPUT(J,NNT) = INPUT(J,I)
 
367
   10         CONTINUE
 
368
          END IF
 
369
 
 
370
   20 CONTINUE
 
371
      NT     = NNT
 
372
      RETURN
 
373
 
 
374
      END
 
375
 
 
376
      SUBROUTINE TDCCSS(MASK,INPUT,OUTPUT,N,ISI,NB,ISO,NBI,NBO)
 
377
C
 
378
C  COPY BYTE SUBSTRINGS ACCORDING TO MASK.
 
379
C SKIP OVER NON SELECTED VALUES
 
380
C
 
381
C      IMPLICIT NONE
 
382
C
 
383
      INTEGER I,J,J1,ISI,NB,NBI,NBO,ISO,IEND,N
 
384
      REAL MASK(N)
 
385
      INTEGER INPUT(NBI,N),OUTPUT(NBO,N)
 
386
C
 
387
      REAL    TBLSEL
 
388
      DOUBLE PRECISION TDTRUE, TDFALS
 
389
C
 
390
C ... GET MACHINE DEPENDENT VALUES
 
391
C
 
392
      CALL TBMCON(TBLSEL, TDTRUE, TDFALS)
 
393
C
 
394
C ... ITERATION
 
395
C
 
396
      IEND   = ISI + NB - 1
 
397
C
 
398
      DO 20 I = 1,N
 
399
          IF (MASK(I).EQ.TBLSEL) THEN
 
400
              J1     = ISO
 
401
              DO 10 J = ISI,IEND
 
402
                  OUTPUT(J1,I) = INPUT(J,I)
 
403
                  J1     = J1 + 1
 
404
   10         CONTINUE
 
405
          END IF
 
406
 
 
407
   20 CONTINUE
 
408
      RETURN
 
409
 
 
410
      END
 
411
 
 
412
      SUBROUTINE TDCCS1(MASK,INPUT,OUTPUT,N,ISI,NB,ISO,NBI,NBO,NT)
 
413
C
 
414
C  COPY BYTE SUBSTRINGS ACCORDING TO MASK.
 
415
C DO NOT SKIP OVER NON SELECTED VALUES
 
416
C
 
417
C      IMPLICIT NONE
 
418
C
 
419
      INTEGER I,J,N,J1,NB,ISI,ISO,NBI,NBO,NT,NNT,IEND
 
420
      REAL MASK(N)
 
421
      INTEGER INPUT(NBI,N),OUTPUT(NBO,N)
 
422
C
 
423
      REAL    TBLSEL
 
424
      DOUBLE PRECISION TDTRUE, TDFALS
 
425
C
 
426
C ... GET MACHINE DEPENDENT VALUES
 
427
C
 
428
      CALL TBMCON(TBLSEL, TDTRUE, TDFALS)
 
429
C
 
430
C ... ITERATION
 
431
C
 
432
      IEND   = ISI + NB - 1
 
433
      NNT    = 0
 
434
C
 
435
      DO 20 I = 1,N
 
436
          IF (MASK(I).EQ.TBLSEL) THEN
 
437
              NNT    = NNT + 1
 
438
              J1     = ISO
 
439
              DO 10 J = ISI,IEND
 
440
                  OUTPUT(J1,NNT) = INPUT(J,I)
 
441
                  J1     = J1 + 1
 
442
   10         CONTINUE
 
443
          END IF
 
444
 
 
445
   20 CONTINUE
 
446
      NT     = NNT
 
447
      RETURN
 
448
 
 
449
      END
 
450
 
 
451
      SUBROUTINE TDCRRR(MASK,IDENT1,IDENT2,IREF,ISORT,NBYTES,INPUT,NBI,
 
452
     +                  ISI,OUTPUT,NBO,ISO,NIN,NOUT)
 
453
C
 
454
C      IMPLICIT NONE
 
455
C COPY BY REFERENCE VALUES
 
456
C REFERENCE COLUMN IN SINGLE PRECISION
 
457
C
 
458
      INTEGER IREF,ISORT,NBYTES,NBI,ISI,ISO,NBO,NIN,NOUT,N
 
459
      INTEGER NB,I,N1,I1,NN1,NEXT
 
460
      REAL MASK(NIN),INPUT(1),OUTPUT(1)
 
461
      REAL IDENT1(NIN),IDENT2(NOUT),ZERO,VALUE
 
462
C
 
463
      INTEGER TINULL
 
464
      REAL    TBLSEL, TRNULL
 
465
      DOUBLE PRECISION TDTRUE, TDFALS, TDNULL
 
466
C
 
467
C ... GET MACHINE DEPENDENT VALUES
 
468
C
 
469
      CALL TBMCON(TBLSEL, TDTRUE, TDFALS)
 
470
      CALL TBMNUL(TINULL, TRNULL, TDNULL)
 
471
C
 
472
      ZERO   = 0.
 
473
      N      = MAX(NIN,NOUT)
 
474
      NB     = NBYTES
 
475
C
 
476
C ... JUMP ACCORDING TO OUTPUT FORMAT
 
477
C
 
478
C     IF(NBYTES+4)10,80,150
 
479
 
 
480
      I = NBYTES+4
 
481
      IF (I .LT. 0) THEN
 
482
         GOTO 10
 
483
      ELSE IF (I .EQ. 0) THEN
 
484
         GOTO 80
 
485
      ELSE 
 
486
         GOTO 150
 
487
      ENDIF
 
488
C
 
489
C ... DOUBLE PRECISION
 
490
C
 
491
   10 CONTINUE
 
492
      IF (IREF.EQ.IABS(ISORT)) THEN
 
493
          IF (ISORT.GT.0) THEN
 
494
              DO 30 I = 1,NIN
 
495
                  VALUE  = IDENT1(I)
 
496
                  IF (MASK(I).EQ.TBLSEL .AND. VALUE.NE.TRNULL) THEN
 
497
                      CALL TZSBAR(IDENT2,NOUT,VALUE,ZERO,1,NEXT)
 
498
                      IF (NEXT.GT.0) THEN
 
499
   20                     N1     = 2*NEXT - 1
 
500
                          I1     = 2*I - 1
 
501
                          OUTPUT(N1) = INPUT(I1)
 
502
                          N1     = N1 + 1
 
503
                          I1     = I1 + 1
 
504
                          OUTPUT(N1) = INPUT(I1)
 
505
C
 
506
C ... CASE OF EQUAL OUTPUT REFERENCES
 
507
C
 
508
                          IF (NEXT.LT.NOUT) THEN
 
509
                              NEXT   = NEXT + 1
 
510
                              IF (IDENT2(NEXT-1).EQ.
 
511
     +                            IDENT2(NEXT)) GO TO 20
 
512
                          END IF
 
513
 
 
514
                      END IF
 
515
 
 
516
                  END IF
 
517
 
 
518
   30         CONTINUE
 
519
 
 
520
          ELSE
 
521
              DO 50 I = 1,NIN
 
522
                  VALUE  = IDENT1(I)
 
523
                  IF (MASK(I).EQ.TBLSEL .AND. VALUE.NE.TRNULL) THEN
 
524
                      CALL TZSBDR(IDENT2,NOUT,VALUE,ZERO,1,NEXT)
 
525
                      IF (NEXT.GT.0) THEN
 
526
   40                     N1     = 2*NEXT - 1
 
527
                          I1     = 2*I - 1
 
528
                          OUTPUT(N1) = INPUT(I1)
 
529
                          N1     = N1 + 1
 
530
                          I1     = I1 + 1
 
531
                          OUTPUT(N1) = INPUT(I1)
 
532
C
 
533
C ... CASE OF EQUAL OUTPUT REFERENCES
 
534
C
 
535
                          IF (NEXT.LT.NOUT) THEN
 
536
                              NEXT   = NEXT + 1
 
537
                              IF (IDENT2(NEXT-1).EQ.
 
538
     +                            IDENT2(NEXT)) GO TO 40
 
539
                          END IF
 
540
 
 
541
                      END IF
 
542
 
 
543
                  END IF
 
544
 
 
545
   50         CONTINUE
 
546
          END IF
 
547
 
 
548
      ELSE
 
549
          DO 70 I = 1,NIN
 
550
              VALUE  = IDENT1(I)
 
551
              IF (MASK(I).EQ.TBLSEL .AND. VALUE.NE.TRNULL) THEN
 
552
                  NN1    = 1
 
553
   60             CALL TZSCSR(IDENT2,NOUT,VALUE,ZERO,NN1,NEXT)
 
554
                  IF (NEXT.GT.0) THEN
 
555
                      N1     = 2*NEXT - 1
 
556
                      I1     = 2*I - 1
 
557
                      OUTPUT(N1) = INPUT(I1)
 
558
                      N1     = N1 + 1
 
559
                      I1     = I1 + 1
 
560
                      OUTPUT(N1) = INPUT(I1)
 
561
                      NN1    = NEXT + 1
 
562
                      IF (NN1.LE.NOUT) GO TO 60
 
563
                  END IF
 
564
 
 
565
              END IF
 
566
 
 
567
   70     CONTINUE
 
568
      END IF
 
569
 
 
570
      RETURN
 
571
C
 
572
C ... SINGLE PRECISION
 
573
C
 
574
   80 CONTINUE
 
575
      IF (IREF.EQ.IABS(ISORT)) THEN
 
576
          IF (ISORT.GT.0) THEN
 
577
              DO 100 I = 1,NIN
 
578
                  VALUE  = IDENT1(I)
 
579
                  IF (MASK(I).EQ.TBLSEL .AND. VALUE.NE.TRNULL) THEN
 
580
                      CALL TZSBAR(IDENT2,NOUT,VALUE,ZERO,1,NEXT)
 
581
                      IF (NEXT.GT.0) THEN
 
582
   90                     OUTPUT(NEXT) = INPUT(I)
 
583
C
 
584
C ... CASE OF EQUAL OUTPUT REFERENCES
 
585
C
 
586
                          IF (NEXT.LT.NOUT) THEN
 
587
                              NEXT   = NEXT + 1
 
588
                              IF (IDENT2(NEXT-1).EQ.
 
589
     +                            IDENT2(NEXT)) GO TO 90
 
590
                          END IF
 
591
 
 
592
                      END IF
 
593
 
 
594
                  END IF
 
595
 
 
596
  100         CONTINUE
 
597
 
 
598
          ELSE
 
599
              DO 120 I = 1,NIN
 
600
                  VALUE  = IDENT1(I)
 
601
                  IF (MASK(I).EQ.TBLSEL .AND. VALUE.NE.TRNULL) THEN
 
602
                      CALL TZSBDR(IDENT2,NOUT,VALUE,ZERO,1,NEXT)
 
603
                      IF (NEXT.GT.0) THEN
 
604
  110                     OUTPUT(NEXT) = INPUT(I)
 
605
C
 
606
C ... CASE OF EQUAL OUTPUT REFERENCES
 
607
C
 
608
                          IF (NEXT.LT.NOUT) THEN
 
609
                              NEXT   = NEXT + 1
 
610
                              IF (IDENT2(NEXT-1).EQ.
 
611
     +                            IDENT2(NEXT)) GO TO 110
 
612
                          END IF
 
613
 
 
614
                      END IF
 
615
 
 
616
                  END IF
 
617
 
 
618
  120         CONTINUE
 
619
          END IF
 
620
 
 
621
      ELSE
 
622
          DO 140 I = 1,NIN
 
623
              VALUE  = IDENT1(I)
 
624
              IF (MASK(I).EQ.TBLSEL .AND. VALUE.NE.TRNULL) THEN
 
625
                  NN1    = 1
 
626
  130             CALL TZSCSR(IDENT2,NOUT,VALUE,ZERO,NN1,NEXT)
 
627
                  IF (NEXT.GT.0) THEN
 
628
                      OUTPUT(NEXT) = INPUT(I)
 
629
                      NN1    = NEXT + 1
 
630
                      IF (NN1.LE.NOUT) GO TO 130
 
631
                  END IF
 
632
 
 
633
              END IF
 
634
 
 
635
  140     CONTINUE
 
636
      END IF
 
637
 
 
638
      RETURN
 
639
C
 
640
C ... CHARACTER STRING
 
641
C
 
642
  150 CONTINUE
 
643
      IF (IREF.EQ.IABS(ISORT)) THEN
 
644
          IF (ISORT.GT.0) THEN
 
645
              DO 170 I = 1,NIN
 
646
                  VALUE  = IDENT1(I)
 
647
                  IF (MASK(I).EQ.TBLSEL .AND. VALUE.NE.TRNULL) THEN
 
648
                      CALL TZSBAR(IDENT2,NOUT,VALUE,ZERO,1,NEXT)
 
649
                      IF (NEXT.GT.0) THEN
 
650
  160                     CALL TDCPBY(INPUT,I,NBI,ISI,OUTPUT,NEXT,NBO,
 
651
     +                                ISO,NB,N)
 
652
C
 
653
C ... CASE OF EQUAL OUTPUT REFERENCES
 
654
C
 
655
                          IF (NEXT.LT.NOUT) THEN
 
656
                              NEXT   = NEXT + 1
 
657
                              IF (IDENT2(NEXT-1).EQ.
 
658
     +                            IDENT2(NEXT)) GO TO 160
 
659
                          END IF
 
660
 
 
661
                      END IF
 
662
 
 
663
                  END IF
 
664
 
 
665
  170         CONTINUE
 
666
 
 
667
          ELSE
 
668
              DO 190 I = 1,NIN
 
669
                  VALUE  = IDENT1(I)
 
670
                  IF (MASK(I).EQ.TBLSEL .AND. VALUE.NE.TRNULL) THEN
 
671
                      CALL TZSBDR(IDENT2,NOUT,VALUE,ZERO,1,NEXT)
 
672
                      IF (NEXT.GT.0) THEN
 
673
  180                     CALL TDCPBY(INPUT,I,NBI,ISI,OUTPUT,NEXT,NBO,
 
674
     +                                ISO,NB,N)
 
675
C
 
676
C ... CASE OF EQUAL OUTPUT REFERENCES
 
677
C
 
678
                          IF (NEXT.LT.NOUT) THEN
 
679
                              NEXT   = NEXT + 1
 
680
                              IF (IDENT2(NEXT-1).EQ.
 
681
     +                            IDENT2(NEXT)) GO TO 180
 
682
                          END IF
 
683
 
 
684
                      END IF
 
685
 
 
686
                  END IF
 
687
 
 
688
  190         CONTINUE
 
689
          END IF
 
690
 
 
691
      ELSE
 
692
          DO 210 I = 1,NIN
 
693
              VALUE  = IDENT1(I)
 
694
              IF (MASK(I).EQ.TBLSEL .AND. VALUE.NE.TRNULL) THEN
 
695
                  NN1    = 1
 
696
  200             CALL TZSCSR(IDENT2,NOUT,VALUE,ZERO,NN1,NEXT)
 
697
                  IF (NEXT.GT.0) THEN
 
698
                      CALL TDCPBY(INPUT,I,NBI,ISI,OUTPUT,NEXT,NBO,ISO,
 
699
     +                            NB,N)
 
700
                      NN1    = NEXT + 1
 
701
                      IF (NN1.LE.NOUT) GO TO 200
 
702
                  END IF
 
703
 
 
704
              END IF
 
705
 
 
706
  210     CONTINUE
 
707
      END IF
 
708
 
 
709
      RETURN
 
710
 
 
711
      END
 
712
 
 
713
      SUBROUTINE TDCRDD(MASK,IDENT1,IDENT2,IREF,ISORT,NBYTES,INPUT,NBI,
 
714
     +                  ISI,OUTPUT,NBO,ISO,NIN,NOUT)
 
715
C
 
716
C COPY BY REFERENCE VALUES
 
717
C REFERENCE COLUMN IN DOUBLE PRECISION
 
718
C
 
719
C      IMPLICIT NONE
 
720
      INTEGER IREF,ISORT,NBYTES,NBI,ISI,ISO,NIN,NOUT,I,I1,N1
 
721
      REAL MASK(NIN),INPUT(1),OUTPUT(1)
 
722
      DOUBLE PRECISION IDENT1(NIN),IDENT2(NOUT),VALUE,ZERO
 
723
C
 
724
      INTEGER TINULL,NBO,N,NB,NEXT,NN1
 
725
      REAL    TBLSEL, TRNULL
 
726
      DOUBLE PRECISION TDTRUE, TDFALS, TDNULL
 
727
C
 
728
C ... GET MACHINE DEPENDENT VALUES
 
729
C
 
730
      CALL TBMCON(TBLSEL, TDTRUE, TDFALS)
 
731
      CALL TBMNUL(TINULL, TRNULL, TDNULL)
 
732
      ZERO   = 0.D0
 
733
      N      = MAX(NIN,NOUT)
 
734
      NB     = NBYTES
 
735
C
 
736
C ... JUMP ACCORDING TO OUTPUT FORMAT
 
737
C
 
738
C     IF (NBYTES+4) 10,80,150
 
739
 
 
740
      I = NBYTES + 4
 
741
      IF (I .LT. 0) THEN
 
742
         GOTO 10
 
743
      ELSE IF (I .EQ. 0) THEN
 
744
         GOTO 80
 
745
      ELSE 
 
746
         GOTO 150
 
747
      ENDIF
 
748
C
 
749
C
 
750
C ... DOUBLE PRECISION
 
751
C
 
752
   10 CONTINUE
 
753
      IF (IREF.EQ.IABS(ISORT)) THEN
 
754
          IF (ISORT.GT.0) THEN
 
755
              DO 30 I = 1,NIN
 
756
                  VALUE  = IDENT1(I)
 
757
                  IF (MASK(I).EQ.TBLSEL .AND. VALUE.NE.TDNULL) THEN
 
758
                      CALL TZSBAD(IDENT2,NOUT,VALUE,ZERO,1,NEXT)
 
759
                      IF (NEXT.GT.0) THEN
 
760
   20                     N1     = 2*NEXT - 1
 
761
                          I1     = 2*I - 1
 
762
                          OUTPUT(N1) = INPUT(I1)
 
763
                          N1     = N1 + 1
 
764
                          I1     = I1 + 1
 
765
                          OUTPUT(N1) = INPUT(I1)
 
766
C
 
767
C ... CASE OF EQUAL OUTPUT REFERENCES
 
768
C
 
769
                          IF (NEXT.LT.NOUT) THEN
 
770
                              NEXT   = NEXT + 1
 
771
                              IF (IDENT2(NEXT-1).EQ.
 
772
     +                            IDENT2(NEXT)) GO TO 20
 
773
                          END IF
 
774
 
 
775
                      END IF
 
776
 
 
777
                  END IF
 
778
 
 
779
   30         CONTINUE
 
780
 
 
781
          ELSE
 
782
              DO 50 I = 1,NIN
 
783
                  VALUE  = IDENT1(I)
 
784
                  IF (MASK(I).EQ.TBLSEL .AND. VALUE.NE.TDNULL) THEN
 
785
                      CALL TZSBDD(IDENT2,NOUT,VALUE,ZERO,1,NEXT)
 
786
                      IF (NEXT.GT.0) THEN
 
787
   40                     N1     = 2*NEXT - 1
 
788
                          I1     = 2*I - 1
 
789
                          OUTPUT(N1) = INPUT(I1)
 
790
                          N1     = N1 + 1
 
791
                          I1     = I1 + 1
 
792
                          OUTPUT(N1) = INPUT(I1)
 
793
C
 
794
C ... CASE OF EQUAL OUTPUT REFERENCES
 
795
C
 
796
                          IF (NEXT.LT.NOUT) THEN
 
797
                              NEXT   = NEXT + 1
 
798
                              IF (IDENT2(NEXT-1).EQ.
 
799
     +                            IDENT2(NEXT)) GO TO 40
 
800
                          END IF
 
801
 
 
802
                      END IF
 
803
 
 
804
                  END IF
 
805
 
 
806
   50         CONTINUE
 
807
          END IF
 
808
 
 
809
      ELSE
 
810
          DO 70 I = 1,NIN
 
811
              VALUE  = IDENT1(I)
 
812
              IF (MASK(I).EQ.TBLSEL .AND. VALUE.NE.TDNULL) THEN
 
813
                  NN1    = 1
 
814
   60             CALL TZSCSD(IDENT2,NOUT,VALUE,ZERO,NN1,NEXT)
 
815
                  IF (NEXT.GT.0) THEN
 
816
                      N1     = 2*NEXT - 1
 
817
                      I1     = 2*I - 1
 
818
                      OUTPUT(N1) = INPUT(I1)
 
819
                      N1     = N1 + 1
 
820
                      I1     = I1 + 1
 
821
                      OUTPUT(N1) = INPUT(I1)
 
822
                      NN1    = NEXT + 1
 
823
                      IF (NN1.LE.NOUT) GO TO 60
 
824
                  END IF
 
825
 
 
826
              END IF
 
827
 
 
828
   70     CONTINUE
 
829
      END IF
 
830
 
 
831
      RETURN
 
832
C
 
833
C ... SINGLE PRECISION
 
834
C
 
835
   80 CONTINUE
 
836
      IF (IREF.EQ.IABS(ISORT)) THEN
 
837
          IF (ISORT.GT.0) THEN
 
838
              DO 100 I = 1,NIN
 
839
                  VALUE  = IDENT1(I)
 
840
                  IF (MASK(I).EQ.TBLSEL .AND. VALUE.NE.TDNULL) THEN
 
841
                      CALL TZSBAD(IDENT2,NOUT,VALUE,ZERO,1,NEXT)
 
842
                      IF (NEXT.GT.0) THEN
 
843
   90                     OUTPUT(NEXT) = INPUT(I)
 
844
C
 
845
C ... CASE OF EQUAL OUTPUT REFERENCES
 
846
C
 
847
                          IF (NEXT.LT.NOUT) THEN
 
848
                              NEXT   = NEXT + 1
 
849
                              IF (IDENT2(NEXT-1).EQ.
 
850
     +                            IDENT2(NEXT)) GO TO 90
 
851
                          END IF
 
852
 
 
853
                      END IF
 
854
 
 
855
                  END IF
 
856
 
 
857
  100         CONTINUE
 
858
 
 
859
          ELSE
 
860
              DO 120 I = 1,NIN
 
861
                  VALUE  = IDENT1(I)
 
862
                  IF (MASK(I).EQ.TBLSEL .AND. VALUE.NE.TDNULL) THEN
 
863
                      CALL TZSBDD(IDENT2,NOUT,VALUE,ZERO,1,NEXT)
 
864
                      IF (NEXT.GT.0) THEN
 
865
  110                     OUTPUT(NEXT) = INPUT(I)
 
866
C
 
867
C ... CASE OF EQUAL OUTPUT REFERENCES
 
868
C
 
869
                          IF (NEXT.LT.NOUT) THEN
 
870
                              NEXT   = NEXT + 1
 
871
                              IF (IDENT2(NEXT-1).EQ.
 
872
     +                            IDENT2(NEXT)) GO TO 110
 
873
                          END IF
 
874
 
 
875
                      END IF
 
876
 
 
877
                  END IF
 
878
 
 
879
  120         CONTINUE
 
880
          END IF
 
881
 
 
882
      ELSE
 
883
          DO 140 I = 1,NIN
 
884
              VALUE  = IDENT1(I)
 
885
              IF (MASK(I).EQ.TBLSEL .AND. VALUE.NE.TDNULL) THEN
 
886
                  NN1    = 1
 
887
  130             CALL TZSCSD(IDENT2,NOUT,VALUE,ZERO,NN1,NEXT)
 
888
                  IF (NEXT.GT.0) THEN
 
889
                      OUTPUT(NEXT) = INPUT(I)
 
890
                      NN1    = NEXT + 1
 
891
                      IF (NN1.LE.NOUT) GO TO 130
 
892
                  END IF
 
893
 
 
894
              END IF
 
895
 
 
896
  140     CONTINUE
 
897
      END IF
 
898
 
 
899
      RETURN
 
900
C
 
901
C ... CHARACTER STRING
 
902
C
 
903
  150 CONTINUE
 
904
      IF (IREF.EQ.IABS(ISORT)) THEN
 
905
          IF (ISORT.GT.0) THEN
 
906
              DO 170 I = 1,NIN
 
907
                  VALUE  = IDENT1(I)
 
908
                  IF (MASK(I).EQ.TBLSEL .AND. VALUE.NE.TDNULL) THEN
 
909
                      CALL TZSBAD(IDENT2,NOUT,VALUE,ZERO,1,NEXT)
 
910
                      IF (NEXT.GT.0) THEN
 
911
  160                     CALL TDCPBY(INPUT,I,NBI,ISI,OUTPUT,NEXT,NBO,
 
912
     +                                ISO,NB,N)
 
913
C
 
914
C ... CASE OF EQUAL OUTPUT REFERENCES
 
915
C
 
916
                          IF (NEXT.LT.NOUT) THEN
 
917
                              NEXT   = NEXT + 1
 
918
                              IF (IDENT2(NEXT-1).EQ.
 
919
     +                            IDENT2(NEXT)) GO TO 160
 
920
                          END IF
 
921
 
 
922
                      END IF
 
923
 
 
924
                  END IF
 
925
 
 
926
  170         CONTINUE
 
927
 
 
928
          ELSE
 
929
              DO 190 I = 1,NIN
 
930
                  VALUE  = IDENT1(I)
 
931
                  IF (MASK(I).EQ.TBLSEL .AND. VALUE.NE.TDNULL) THEN
 
932
                      CALL TZSBDD(IDENT2,NOUT,VALUE,ZERO,1,NEXT)
 
933
                      IF (NEXT.GT.0) THEN
 
934
  180                     CALL TDCPBY(INPUT,I,NBI,ISI,OUTPUT,NEXT,NBO,
 
935
     +                                ISO,NB,N)
 
936
C
 
937
C ... CASE OF EQUAL OUTPUT REFERENCES
 
938
C
 
939
                          IF (NEXT.LT.NOUT) THEN
 
940
                              NEXT   = NEXT + 1
 
941
                              IF (IDENT2(NEXT-1).EQ.
 
942
     +                            IDENT2(NEXT)) GO TO 180
 
943
                          END IF
 
944
 
 
945
                      END IF
 
946
 
 
947
                  END IF
 
948
 
 
949
  190         CONTINUE
 
950
          END IF
 
951
 
 
952
      ELSE
 
953
          DO 210 I = 1,NIN
 
954
              VALUE  = IDENT1(I)
 
955
              IF (MASK(I).EQ.TBLSEL .AND. VALUE.NE.TDNULL) THEN
 
956
                  NN1    = 1
 
957
  200             CALL TZSCSD(IDENT2,NOUT,VALUE,ZERO,NN1,NEXT)
 
958
                  IF (NEXT.GT.0) THEN
 
959
                      CALL TDCPBY(INPUT,I,NBI,ISI,OUTPUT,NEXT,NBO,ISO,
 
960
     +                            NB,N)
 
961
                      NN1    = NEXT + 1
 
962
                      IF (NN1.LE.NOUT) GO TO 200
 
963
                  END IF
 
964
 
 
965
              END IF
 
966
 
 
967
  210     CONTINUE
 
968
      END IF
 
969
 
 
970
      RETURN
 
971
 
 
972
      END
 
973
 
 
974
      SUBROUTINE TDCRSS(MASK,IDENT1,IDENT2,NW,NBR,IREF,ISORT,NBYTES,
 
975
     +                  INPUT,NBI,ISI,OUTPUT,NBO,ISO,NIN,NOUT)
 
976
C      IMPLICIT NONE
 
977
C
 
978
C COPY BY REFERENCE VALUES
 
979
C REFERENCE COLUMN AS CHARACTER STRING
 
980
C
 
981
      INTEGER NBR,NW,IREF,ISORT,NBYTES,NBI,NBO,ISI,ISO,NIN
 
982
      INTEGER NOUT,I,NEXT,I1,N1,NB,N
 
983
      REAL MASK(NIN),INPUT(1),OUTPUT(1)
 
984
      INTEGER IDENT1(NW,NIN),IDENT2(NW,NOUT),VALUE
 
985
C
 
986
      INTEGER TINULL
 
987
      REAL    TBLSEL, TRNULL
 
988
      DOUBLE PRECISION TDTRUE, TDFALS, TDNULL
 
989
C
 
990
C ... GET MACHINE DEPENDENT VALUES
 
991
C
 
992
      CALL TBMCON(TBLSEL, TDTRUE, TDFALS)
 
993
      CALL TBMNUL(TINULL, TRNULL, TDNULL)
 
994
C
 
995
      N      = MAX(NIN,NOUT)
 
996
      NB     = NBYTES
 
997
C
 
998
C ... JUMP ACCORDING TO OUTPUT FORMAT
 
999
C
 
1000
C     IF (NBYTES+4) 10,50,90
 
1001
 
 
1002
      I = NBYTES + 4
 
1003
      IF (I .LT. 0) THEN
 
1004
         GOTO 10
 
1005
      ELSE IF (I .EQ. 0) THEN
 
1006
         GOTO 50
 
1007
      ELSE 
 
1008
         GOTO 90
 
1009
      ENDIF
 
1010
C
 
1011
C
 
1012
C ... DOUBLE PRECISION
 
1013
C
 
1014
   10 CONTINUE
 
1015
      IF (IREF.EQ.IABS(ISORT)) THEN
 
1016
          IF (ISORT.GT.0) THEN
 
1017
              DO 20 I = 1,NIN
 
1018
                  VALUE  = IDENT1(1,I)
 
1019
                  IF (MASK(I).EQ.TBLSEL .AND. VALUE.NE.0) THEN
 
1020
                      CALL TZSBAC(IDENT2,NW,NOUT,IDENT1(1,I),1,NBR,1,
 
1021
     +                            NEXT)
 
1022
                      IF (NEXT.GT.0) THEN
 
1023
                          N1     = 2*NEXT - 1
 
1024
                          I1     = 2*I - 1
 
1025
                          OUTPUT(N1) = INPUT(I1)
 
1026
                          N1     = N1 + 1
 
1027
                          I1     = I1 + 1
 
1028
                          OUTPUT(N1) = INPUT(I1)
 
1029
                      END IF
 
1030
 
 
1031
                  END IF
 
1032
 
 
1033
   20         CONTINUE
 
1034
 
 
1035
          ELSE
 
1036
              DO 30 I = 1,NIN
 
1037
                  VALUE  = IDENT1(1,I)
 
1038
                  IF (MASK(I).EQ.TBLSEL .AND. VALUE.NE.0) THEN
 
1039
                      CALL TZSBDC(IDENT2,NW,NOUT,IDENT1(1,I),1,NBR,1,
 
1040
     +                            NEXT)
 
1041
                      IF (NEXT.GT.0) THEN
 
1042
                          N1     = 2*NEXT - 1
 
1043
                          I1     = 2*I - 1
 
1044
                          OUTPUT(N1) = INPUT(I1)
 
1045
                          N1     = N1 + 1
 
1046
                          I1     = I1 + 1
 
1047
                          OUTPUT(N1) = INPUT(I1)
 
1048
                      END IF
 
1049
 
 
1050
                  END IF
 
1051
 
 
1052
   30         CONTINUE
 
1053
          END IF
 
1054
 
 
1055
      ELSE
 
1056
          DO 40 I = 1,NIN
 
1057
              VALUE  = IDENT1(1,I)
 
1058
              IF (MASK(I).EQ.TBLSEL .AND. VALUE.NE.0) THEN
 
1059
                  CALL TZSCSC(IDENT2,NW,NOUT,IDENT1(1,I),1,NBR,1,NEXT)
 
1060
                  IF (NEXT.GT.0) THEN
 
1061
                      N1     = 2*NEXT - 1
 
1062
                      I1     = 2*I - 1
 
1063
                      OUTPUT(N1) = INPUT(I1)
 
1064
                      N1     = N1 + 1
 
1065
                      I1     = I1 + 1
 
1066
                      OUTPUT(N1) = INPUT(I1)
 
1067
                  END IF
 
1068
 
 
1069
              END IF
 
1070
 
 
1071
   40     CONTINUE
 
1072
      END IF
 
1073
 
 
1074
      RETURN
 
1075
C
 
1076
C ... SINGLE PRECISION
 
1077
C
 
1078
   50 CONTINUE
 
1079
      IF (IREF.EQ.IABS(ISORT)) THEN
 
1080
          IF (ISORT.GT.0) THEN
 
1081
              DO 60 I = 1,NIN
 
1082
                  VALUE  = IDENT1(1,I)
 
1083
                  IF (MASK(I).EQ.TBLSEL .AND. VALUE.NE.0) THEN
 
1084
                      CALL TZSBAC(IDENT2,NW,NOUT,IDENT1(1,I),1,NBR,1,
 
1085
     +                            NEXT)
 
1086
                      IF (NEXT.GT.0) OUTPUT(NEXT) = INPUT(I)
 
1087
                  END IF
 
1088
 
 
1089
   60         CONTINUE
 
1090
 
 
1091
          ELSE
 
1092
              DO 70 I = 1,NIN
 
1093
                  VALUE  = IDENT1(1,I)
 
1094
                  IF (MASK(I).EQ.TBLSEL .AND. VALUE.NE.0) THEN
 
1095
                      CALL TZSBDC(IDENT2,NW,NOUT,IDENT1(1,I),1,NBR,1,
 
1096
     +                            NEXT)
 
1097
                      IF (NEXT.GT.0) OUTPUT(NEXT) = INPUT(I)
 
1098
                  END IF
 
1099
 
 
1100
   70         CONTINUE
 
1101
          END IF
 
1102
 
 
1103
      ELSE
 
1104
          DO 80 I = 1,NIN
 
1105
              VALUE  = IDENT1(1,I)
 
1106
              IF (MASK(I).EQ.TBLSEL .AND. VALUE.NE.0) THEN
 
1107
                  CALL TZSCSC(IDENT2,NW,NOUT,IDENT1(1,I),1,NBR,1,NEXT)
 
1108
                  IF (NEXT.GT.0) OUTPUT(NEXT) = INPUT(I)
 
1109
              END IF
 
1110
 
 
1111
   80     CONTINUE
 
1112
      END IF
 
1113
 
 
1114
      RETURN
 
1115
C
 
1116
C ... CHARACTER STRING
 
1117
C
 
1118
   90 CONTINUE
 
1119
      IF (IREF.EQ.IABS(ISORT)) THEN
 
1120
          IF (ISORT.GT.0) THEN
 
1121
              DO 100 I = 1,NIN
 
1122
                  VALUE  = IDENT1(1,I)
 
1123
                  IF (MASK(I).EQ.TBLSEL .AND. VALUE.NE.0) THEN
 
1124
                      CALL TZSBAC(IDENT2,NW,NOUT,IDENT1(1,I),1,NBR,1,
 
1125
     +                            NEXT)
 
1126
                      IF (NEXT.GT.0) CALL TDCPBY(INPUT,I,NBI,ISI,OUTPUT,
 
1127
     +                                    NEXT,NBO,ISO,NB,N)
 
1128
                  END IF
 
1129
 
 
1130
  100         CONTINUE
 
1131
 
 
1132
          ELSE
 
1133
              DO 110 I = 1,NIN
 
1134
                  VALUE  = IDENT1(1,I)
 
1135
                  IF (MASK(I).EQ.TBLSEL .AND. VALUE.NE.0) THEN
 
1136
                      CALL TZSBDC(IDENT2,NW,NOUT,IDENT1(1,I),1,NBR,1,
 
1137
     +                            NEXT)
 
1138
                      IF (NEXT.GT.0) CALL TDCPBY(INPUT,I,NBI,ISI,OUTPUT,
 
1139
     +                                    NEXT,NBO,ISO,NB,N)
 
1140
                  END IF
 
1141
 
 
1142
  110         CONTINUE
 
1143
          END IF
 
1144
 
 
1145
      ELSE
 
1146
          DO 120 I = 1,NIN
 
1147
              VALUE  = IDENT1(1,I)
 
1148
              IF (MASK(I).EQ.TBLSEL .AND. VALUE.NE.0) THEN
 
1149
                  CALL TZSCSC(IDENT2,NW,NOUT,IDENT1(1,I),1,NBR,1,NEXT)
 
1150
                  IF (NEXT.GT.0) CALL TDCPBY(INPUT,I,NBI,ISI,OUTPUT,
 
1151
     +                                NEXT,NBO,ISO,NB,N)
 
1152
              END IF
 
1153
 
 
1154
  120     CONTINUE
 
1155
      END IF
 
1156
 
 
1157
      RETURN
 
1158
 
 
1159
      END
 
1160
 
 
1161
      SUBROUTINE TDCPBY(INPUT,IP,NBI,ISI,OUTPUT,NEXT,NBO,ISO,NB,N)
 
1162
C
 
1163
C COPY BYTE STRING
 
1164
C      IMPLICIT NONE
 
1165
C
 
1166
      INTEGER IP,NBI,ISI,NEXT,NBO,ISO,NB,I,N,I1,I2
 
1167
      INTEGER INPUT(NBI,N),OUTPUT(NBO,N)
 
1168
C
 
1169
      DO 10 I = 0,NB - 1
 
1170
          I1     = I + ISI
 
1171
          I2     = I + ISO
 
1172
          OUTPUT(I2,NEXT) = INPUT(I1,IP)
 
1173
   10 CONTINUE
 
1174
      RETURN
 
1175
 
 
1176
      END