*DECK MSTCPB
      SUBROUTINE MSTCPB(IPSTR,IPSTR2,IPRINT,IBEG,IEND,IINC,NAME,NAME2,
     1                  NBLOCK,BLNAM,BLTYP,BLLEN)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Copy some elements from a structure's block to another.
*
*Copyright:
* Copyright (C) 2002 Ecole Polytechnique de Montreal
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version
*
*Author(s): R. Le Tellier
*
*Parameters: input
* IPSTR   address of the structure from which the information is
*         retrieved.
* IPSTR2  destination structure address.
* IPRINT  level of print index.
* IBEG    index of the first element.
* IEND    index of the last element.
* IINC    index increment between two consecutive elements.
* NAME    name of the block from which the information is retrieved.
* NAME2   destination block name.
* NBLOCK  number of existing block in the directory.
* BLNAM   names of these blocks.
* BLTYP   types of these blocks.
* BLLEN   lengths of these blocks.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
      IMPLICIT NONE
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) :: IPSTR,IPSTR2
      INTEGER :: IPRINT,IBEG,IEND,IINC,NBLOCK,BLNAM(3,NBLOCK+1),
     1           BLTYP(NBLOCK+1),BLLEN(NBLOCK+1)
      CHARACTER(LEN=12) :: NAME,NAME2  
*----
*  LOCAL VARIABLES
*----
      INTEGER, PARAMETER :: IOUT=6
      INTEGER, PARAMETER :: NSTATE=40
      INTEGER :: ISTATE(NSTATE),KCHAR(3),NARA,ITYP,SIZE,ITYPO,NELEO,
     1           NARA2,II,JJ,SIZE2
      CHARACTER(LEN=12) :: WHITE12
      LOGICAL :: EXIST
      INTEGER, ALLOCATABLE, DIMENSION(:) :: IARA,IARA2
      REAL, ALLOCATABLE, DIMENSION(:) :: ARA,ARA2
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DARA,DARA2
*----
*  RETRIEVING BLOCK TO BE COPIED
*----
      CALL LCMLEN(IPSTR,NAME,SIZE,ITYP)
      IF (SIZE.LE.0) THEN
         CALL LCMLIB(IPSTR)
         CALL XABORT('MSTCPB: INVALID BLOCK '//NAME//'.')
      ENDIF
      NARA=0
      IF (ITYP.EQ.1) THEN
         NARA=SIZE
         ALLOCATE(IARA(NARA))
         CALL LCMGET(IPSTR,NAME,IARA)
      ELSEIF (ITYP.LE.2) THEN
         NARA=SIZE
         ALLOCATE(ARA(NARA))
         CALL LCMGET(IPSTR,NAME,ARA)
      ELSEIF (ITYP.EQ.3) THEN
         NARA=SIZE/3
         ALLOCATE(IARA(3*NARA))
         CALL LCMGET(IPSTR,NAME,IARA)
      ELSEIF (ITYP.EQ.4) THEN
         NARA=SIZE/2
         ALLOCATE(DARA(NARA))
         CALL LCMGET(IPSTR,NAME,DARA)
      ELSE 
         CALL XABORT('MSTCPB: UNSUPPORTED TYPE')
      ENDIF
      IF (IEND.GT.NARA) CALL XABORT('MSTCPB: INCOMPATIBLE SIZE')
*     DOES THIS BLOCK ALREADY EXIST IN THE DESTINATION STRUCTURE ?
      EXIST=.FALSE.
      NELEO=0
*     SPECIAL CASE OF STATE-VECTOR MODIFICATION
      IF (NAME2.EQ.'STATE-VECTOR') THEN
         IF (IEND.GT.40)
     1      CALL XABORT('MSTCPM: STATE-VECTOR SIZE IS LIMITED TO 40.')
         IF (IEND.EQ.40)
     2      CALL XABORT('MSTCPM: 40th STATE-VECTOR ELEMENT SHOULD'//
     3      ' NOT BE MODIFIED.')
         ITYPO=1
         NELEO=NSTATE
         EXIST=.TRUE.
      ENDIF
      IF (NBLOCK.NE.0) THEN
         READ(NAME2,'(3A4)') (KCHAR(II),II=1,3)
         DO II=1,NBLOCK
            IF((BLNAM(1,II).EQ.KCHAR(1)).AND.
     1         (BLNAM(2,II).EQ.KCHAR(2)).AND.
     2         (BLNAM(3,II).EQ.KCHAR(3))) THEN
               ITYPO=BLTYP(II)
               IF (ITYPO.EQ.0)
     1           CALL XABORT('MSTCPM: '//NAME2//
     2                       ' IS AN EXISTING DIRECTORY.')
               IF (ITYPO.NE.ITYP)
     1           CALL XABORT('MSTCPM: INCOMPATIBLE TYPES')
               NELEO=BLLEN(II)
               EXIST=.TRUE.
               GOTO 20
            ENDIF
         ENDDO
 20      CONTINUE
      ENDIF
      IF (IPRINT.GT.2) THEN
      IF (EXIST) THEN
*     YES: IT WILL BE UPDATED
         WRITE(IOUT,*) 'MSTCPB: BLOCK '//NAME//' IN UPDATE MODE'
      ELSE
*     NO: IT WILL BE CREATED
         WRITE(IOUT,*) 'MSTCPB: BLOCK '//NAME//' IN CREATION MODE'
      ENDIF
      ENDIF      
      NARA2=MAX(NARA,NELEO)
*     ALLOCATE MEMORY
      IF (ITYP.EQ.1) THEN
         SIZE2=NARA2
         ALLOCATE(IARA2(NARA2))
      ELSEIF (ITYP.EQ.2) THEN
         SIZE2=NARA2
         ALLOCATE(ARA2(NARA2))
      ELSEIF (ITYP.EQ.3) THEN
         SIZE2=3*NARA2
         ALLOCATE(IARA2(3*NARA2))
      ELSEIF (ITYP.EQ.4) THEN
         SIZE2=2*NARA2
         ALLOCATE(DARA2(NARA2))
      ENDIF
*     INITIALIZE BLOCK
      IF (EXIST) THEN
         IF (ITYP.EQ.1) THEN
            CALL LCMGET(IPSTR2,NAME2,IARA2)
         ELSEIF (ITYP.EQ.2) THEN
            CALL LCMGET(IPSTR2,NAME2,ARA2)
         ELSEIF (ITYP.EQ.3) THEN
            CALL LCMGET(IPSTR2,NAME2,IARA2)
         ELSEIF (ITYP.EQ.4) THEN
            CALL LCMGET(IPSTR2,NAME2,DARA2)
         ENDIF
      ELSE
         IF (ITYP.EQ.1) THEN
            IARA2(:NARA)=0
         ELSEIF (ITYP.EQ.2) THEN
            ARA2(:NARA)=0
         ELSEIF (ITYP.EQ.3) THEN
            WHITE12=' '
            DO II=1,NARA
               READ(WHITE12,'(3A4)') (IARA2(3*(II-1)+JJ),JJ=0,2)
            ENDDO
         ELSEIF (ITYP.EQ.4) THEN
            DARA2(:NARA)=0.D0
         ENDIF
      ENDIF
*     COPY ACTION
      DO II=IBEG,IEND,IINC
         IF (ITYP.EQ.1) THEN
            IARA2(II)=IARA(II)
         ELSEIF (ITYP.EQ.2) THEN
            ARA2(II)=ARA(II)
         ELSEIF (ITYP.EQ.3) THEN
            DO JJ=0,2
               IARA2(3*(II-1)+JJ)=IARA(3*(II-1)+JJ)
            ENDDO
         ELSEIF (ITYP.EQ.4) THEN
            DARA2(II)=DARA(II)
         ENDIF
      ENDDO
      IF (ITYP.EQ.1) THEN
         CALL LCMPUT(IPSTR2,NAME2,SIZE2,ITYP,IARA2)
         DEALLOCATE(IARA2)
         DEALLOCATE(IARA)
      ELSEIF (ITYP.EQ.2) THEN
         CALL LCMPUT(IPSTR2,NAME2,SIZE2,ITYP,ARA2)
         DEALLOCATE(ARA2)
         DEALLOCATE(ARA)
      ELSEIF (ITYP.EQ.3) THEN
         CALL LCMPUT(IPSTR2,NAME2,SIZE2,ITYP,IARA2)
         DEALLOCATE(IARA2)
         DEALLOCATE(IARA)
      ELSEIF (ITYP.EQ.4) THEN
         CALL LCMPUT(IPSTR2,NAME2,SIZE2,ITYP,DARA2)
         DEALLOCATE(DARA2)
         DEALLOCATE(DARA)
      ENDIF
*----
*  UPDATE NB. BLOCKS, REC-NAMES, REC-TYPES, REC-LENGTHS IN STATE-VECTOR
*  IF REQUIRED
*----
      IF (.NOT.EXIST) THEN
         CALL LCMGET(IPSTR2,'STATE-VECTOR',ISTATE)
         ISTATE(40)=ISTATE(40)+1
         READ(NAME,'(3A4)') (BLNAM(II,NBLOCK+1),II=1,3)
         BLTYP(NBLOCK+1)=ITYP
         BLLEN(NBLOCK+1)=NARA
         CALL LCMPUT(IPSTR2,'STATE-VECTOR',NSTATE,1,ISTATE)
         CALL LCMPUT(IPSTR2,'REC-NAMES',3*(NBLOCK+1),3,BLNAM)
         CALL LCMPUT(IPSTR2,'REC-TYPES',(NBLOCK+1),1,BLTYP)
         CALL LCMPUT(IPSTR2,'REC-LENGTHS',(NBLOCK+1),1,BLLEN)
      ENDIF
      RETURN
      END
