[u/mrichter/AliRoot.git] / MINICERN / packlib / kernlib / kerngen / tcgens / uhtoc.F

*
* $Id$
*
* $Log$
* Revision 1.2  1996/04/02 23:17:49  thakulin
* Add support for EPC Fortran:  remove char-int equivalences and use
* F90 transfer facility instead.
*
* Revision 1.1.1.1  1996/02/15 17:50:15  mclareni
* Kernlib
*
*
#include "kerngen/pilot.h"
      SUBROUTINE UHTOC (MS,NPW,MT,NCH)
C
C CERN PROGLIB# M409    UHTOC           .VERSION KERNFOR  4.21  890323
C ORIG. 10/02/89  JZ
C
      DIMENSION    MS(99)
      CHARACTER    MT*99

#include "kerngen/wordsize.inc"
      CHARACTER    CHWORD*(NCHAPW)
      INTEGER      IWORD
#if !defined(CERNLIB_F90) && !defined(CERNLIB_QFEPC)
      EQUIVALENCE (IWORD,CHWORD)
#endif

      IF   (NCH)             91, 29, 11
   11 IF (NPW.LE.0)          GO TO 91
      IF (NPW.EQ.1)          GO TO 21
      IF (NPW.LT.NCHAPW)     GO TO 31

C--------          NPW = maximum

      JT     = 0
      NWS    = NCH / NCHAPW
      NTRAIL = NCH - NWS*NCHAPW

      DO 14  JS=1,NWS
      IWORD  = MS(JS)
#if defined(CERNLIB_F90) || defined(CERNLIB_QFEPC)
      MT(JT+1:JT+NCHAPW) = transfer(IWORD,CHWORD)
#else
      MT(JT+1:JT+NCHAPW) = CHWORD
#endif
   14 JT  = JT + NCHAPW

      IF (NTRAIL.EQ.0)       RETURN

      IWORD = MS(NWS+1)
#if defined(CERNLIB_F90) || defined(CERNLIB_QFEPC)
      CHWORD = transfer(IWORD,CHWORD)
#endif
      MT(JT+1:JT+NTRAIL) = CHWORD(1:NTRAIL)
      RETURN

C--------          NPW = 1
C--                equivalent to 'CALL UH1TOC(MS,MT,NCH)'

   21 DO 24  JS=1,NCH
      IWORD  = MS(JS)
#if defined(CERNLIB_F90) || defined(CERNLIB_QFEPC)
      CHWORD = transfer(IWORD,CHWORD) 
#endif
      MT(JS:JS) = CHWORD(1:1)
   24 CONTINUE
   29 RETURN

C--------          NPW = 2 ...

   31 JT     = 0
      NWS    = NCH / NPW
      NTRAIL = NCH - NWS*NPW

      DO 34  JS=1,NWS
      IWORD  = MS(JS)
#if defined(CERNLIB_F90) || defined(CERNLIB_QFEPC)
      CHWORD = transfer(IWORD,CHWORD)
#endif
      MT(JT+1:JT+NPW) = CHWORD(1:NPW)
   34 JT  = JT + NPW

      IF (NTRAIL.EQ.0)       RETURN

      IWORD = MS(NWS+1)
#if defined(CERNLIB_F90) || defined(CERNLIB_QFEPC)
      CHWORD = transfer(IWORD,CHWORD)
#endif
      MT(JT+1:JT+NTRAIL) = CHWORD(1:NTRAIL)
      RETURN

   91 CALL ABEND
      END
Commit	Line	Data
fe4da5cc	1	*
	2	* $Id$
	3	*
	4	* $Log$
	5	* Revision 1.2 1996/04/02 23:17:49 thakulin
	6	* Add support for EPC Fortran: remove char-int equivalences and use
	7	* F90 transfer facility instead.
	8	*
	9	* Revision 1.1.1.1 1996/02/15 17:50:15 mclareni
	10	* Kernlib
	11	*
	12	*
	13	#include "kerngen/pilot.h"
	14	SUBROUTINE UHTOC (MS,NPW,MT,NCH)
	15	C
	16	C CERN PROGLIB# M409 UHTOC .VERSION KERNFOR 4.21 890323
	17	C ORIG. 10/02/89 JZ
	18	C
	19	DIMENSION MS(99)
	20	CHARACTER MT*99
	21
	22	#include "kerngen/wordsize.inc"
	23	CHARACTER CHWORD*(NCHAPW)
	24	INTEGER IWORD
	25	#if !defined(CERNLIB_F90) && !defined(CERNLIB_QFEPC)
	26	EQUIVALENCE (IWORD,CHWORD)
	27	#endif
	28
	29	IF (NCH) 91, 29, 11
	30	11 IF (NPW.LE.0) GO TO 91
	31	IF (NPW.EQ.1) GO TO 21
	32	IF (NPW.LT.NCHAPW) GO TO 31
	33
	34	C-------- NPW = maximum
	35
	36	JT = 0
	37	NWS = NCH / NCHAPW
	38	NTRAIL = NCH - NWS*NCHAPW
	39
	40	DO 14 JS=1,NWS
	41	IWORD = MS(JS)
	42	#if defined(CERNLIB_F90) \|\| defined(CERNLIB_QFEPC)
	43	MT(JT+1:JT+NCHAPW) = transfer(IWORD,CHWORD)
	44	#else
	45	MT(JT+1:JT+NCHAPW) = CHWORD
	46	#endif
	47	14 JT = JT + NCHAPW
	48
	49	IF (NTRAIL.EQ.0) RETURN
	50
	51	IWORD = MS(NWS+1)
	52	#if defined(CERNLIB_F90) \|\| defined(CERNLIB_QFEPC)
	53	CHWORD = transfer(IWORD,CHWORD)
	54	#endif
	55	MT(JT+1:JT+NTRAIL) = CHWORD(1:NTRAIL)
	56	RETURN
	57
	58	C-------- NPW = 1
	59	C-- equivalent to 'CALL UH1TOC(MS,MT,NCH)'
	60
	61	21 DO 24 JS=1,NCH
	62	IWORD = MS(JS)
	63	#if defined(CERNLIB_F90) \|\| defined(CERNLIB_QFEPC)
	64	CHWORD = transfer(IWORD,CHWORD)
65	#endif
66	MT(JS:JS) = CHWORD(1:1)
67	24 CONTINUE
68	29 RETURN
69
70	C-------- NPW = 2 ...
71
72	31 JT = 0
73	NWS = NCH / NPW
74	NTRAIL = NCH - NWS*NPW
75
76	DO 34 JS=1,NWS
77	IWORD = MS(JS)
78	#if defined(CERNLIB_F90) \|\| defined(CERNLIB_QFEPC)
79	CHWORD = transfer(IWORD,CHWORD)
80	#endif
81	MT(JT+1:JT+NPW) = CHWORD(1:NPW)
82	34 JT = JT + NPW
83
84	IF (NTRAIL.EQ.0) RETURN
85
86	IWORD = MS(NWS+1)
87	#if defined(CERNLIB_F90) \|\| defined(CERNLIB_QFEPC)
88	CHWORD = transfer(IWORD,CHWORD)
89	#endif
90	MT(JT+1:JT+NTRAIL) = CHWORD(1:NTRAIL)
91	RETURN
92
93	91 CALL ABEND
94	END