*"表題 内部設定格子の参照/設定 GTOOL3(GUQIAX)
*
*"履歴 90/09/14 沼口  敦
*
*
*********************************************************************
*"         << 内部設定格子の参照 >>
*********************************************************************
      SUBROUTINE GUQIAX
     I         ( HAXIS , HKIND ,
     O           HHEAD , AXIS  , IEOD   )
*
      CHARACTER  HAXIS      *(*)         !" 格子識別名称
      CHARACTER  HKIND *(*)              !" LOC/WGT
      CHARACTER  HHEAD ( * )*(*)         !" ヘッダー
      REAL       AXIS  ( * )             !" 位置/重み
      INTEGER    IEOD                    !" データなしフラグ
*
      REAL       AXLOC ( * )             !" 位置
      REAL       AXWGT ( * )             !" 重み
      INTEGER    INUM                    !" 内部設定格子番号
      REAL       AXLOC1                  !" 位置
      REAL       AXWGT1                  !" 重み
      INTEGER    IZ                      !" 格子番号
*
#ifdef SYS_IBMS
      INCLUDE    (GZSIZE)                !" NCC, NDC
#else
#include         "gzsize.F"              !" NCC, NDC
#endif
#ifdef SYS_IBMS
      INCLUDE   (GZIWRK)                 !" NW: 格子ワーク大きさ
#else
#include        "gziwrk.F"               !" NW: 格子ワーク大きさ
#endif
      CHARACTER  HAXISA(      NAXIS )*(NCC)
      DATA       HAXISA / NAXIS*' ' /
      CHARACTER  HHEADA( NDC, NAXIS )*(NCC)
      REAL       AXLOCA( NW , NAXIS )
      REAL       AXWGTA( NW , NAXIS )
      SAVE       HAXISA, HHEADA, AXLOCA, AXWGTA
      CHARACTER  HDS   *(NCC)
      CHARACTER  HAITM *(NCC)
      CHARACTER  HAXF  *(NFILN)
      CHARACTER  HFILE *(NFILN)
      CHARACTER  HMSG  * 100
*
      DO 1100 IA = 1, NAXIS
         IF ( HAXIS .EQ. HAXISA( IA ) ) THEN
*
            CALL GHCOPY ( HHEADA( 1,IA ), HHEAD )
            CALL GHPGET ( HHEAD , 'ASTR1', IZSTR )
            CALL GHPGET ( HHEAD , 'AEND1', IZEND )
            CALL GUSZCK ( HHEAD , IZEND-IZSTR+1  )
*
            CALL GHCGET ( HHEAD , 'DSET', HDS    )
            IF ( HDS(1:1) .EQ. 'C' ) THEN
               IDS = 2
            ELSE
               IDS = 1
            ENDIF
*
            IF      ( HKIND(1:1).EQ.'L' ) THEN
               CALL VRSET( AXLOCA(1,IA), AXIS, IZEND-IZSTR+1, 1, 1 )
               HDS(IDS:NCC) = 'IAXLOC'
            ELSE IF ( HKIND(1:1).EQ.'W' ) THEN
               CALL VRSET( AXWGTA(1,IA), AXIS, IZEND-IZSTR+1, 1, 1 )
               HDS(IDS:NCC) = 'IAXWGT'
            ELSE
               CALL MSGDMP( 'W','GUQIAX',
     I                      'IRREGAL HKIND: <LOC> ASSUMED.' )
               CALL VRSET( AXLOCA(1,IA), AXIS, IZEND-IZSTR+1, 1, 1 )
               HDS(IDS:NCC) = 'IAXLOC'
            ENDIF
            CALL GHCSET ( HHEAD , 'DSET', HDS    )
            IEOD = 0
*
            RETURN
         END IF
 1100 CONTINUE
*
      IEOD = 1
*
      RETURN
*====================================================================
*"         << 内部設定格子ヘッダーの参照 >>
*====================================================================
      ENTRY      GUQIAH
     I         ( HAXIS ,
     O           HHEAD , IEOD   )
*
      DO 2100 IA = 1, NAXIS
         IF ( HAXIS .EQ. HAXISA( IA ) ) THEN
            CALL GHCOPY ( HHEADA( 1,IA ), HHEAD )
            IEOD = 0
            RETURN
         END IF
 2100 CONTINUE
*
      IEOD = 1
*
      RETURN
*=======================================================================
*"         << 内部設定格子の設定 >>
*=======================================================================
      ENTRY      GUSIAX
     I         ( HHEAD , AXLOC , AXWGT ,
     I           INUM                   )
*
      IF ( ( INUM .LE. 0 ) .OR. ( INUM .GT. NAXIS ) ) THEN
         HMSG = 'AXIS NUM IS OVER RANGE :'
         NMSG = LENC( HMSG )
         WRITE ( HMSG(NMSG+2:NMSG+4), '(I3)' ) INUM
         CALL MSGDMP( 'W', 'GUSIAX', HMSG )
         RETURN
      ENDIF
*
      CALL GHCGET ( HHEAD , 'ITEM' , HAITM  )
*
      CALL GHPGET ( HHEAD , 'ASTR1', IZSTR  )
      CALL GHPGET ( HHEAD , 'AEND1', IZEND  )
      CALL GUSZCZ ( NW    , IZEND-IZSTR+1   )
*
      HAXISA( INUM ) = HAITM
      CALL GHCOPY ( HHEAD, HHEADA( 1,INUM ) )
      CALL VRSET  ( AXLOC, AXLOCA( 1,INUM ), IZEND-IZSTR+1, 1, 1 )
      CALL VRSET  ( AXWGT, AXWGTA( 1,INUM ), IZEND-IZSTR+1, 1, 1 )
*
      RETURN
*=======================================================================
*"         << 内部設定格子座標の付加設定 >>
*=======================================================================
      ENTRY      GUAIAX
     I         ( HAXIS , AXLOC1, AXWGT1,
     I           IZ                      )
*
      DO 4100 IA = 1, NAXIS
         IF ( HAXIS .EQ. HAXISA( IA ) ) THEN
*
            CALL GHPGET ( HHEADA(1,IA), 'ASTR1', IZSTR  )
            CALL GHPGET ( HHEADA(1,IA), 'AEND1', IZEND  )
            CALL GHPGET ( HHEADA(1,IA), 'MISS' , VMISS  )
            IF ( IZ .EQ. 0 ) THEN
               IZ1 = IZEND + 1
            ELSE
               IZ1 = IZ
            ENDIF
*
            CALL GUSZCZ ( NW    , IZ1-IZSTR+1   )
            AXLOCA( IZ1-IZSTR+1, IA ) = AXLOC1
            AXWGTA( IZ1-IZSTR+1, IA ) = AXWGT1
            IF ( IZ1 .GT. IZEND ) THEN
               CALL GHPSET ( HHEADA( 1,IA ), 'AEND1', IZ1 )
               CALL RSET ( AXLOCA( IZEND-IZSTR+2,IA ),
     I                     IZ1-IZEND-1, 1, VMISS      )
               CALL RSET ( AXWGTA( IZEND-IZSTR+2,IA ),
     I                     IZ1-IZEND-1, 1, VMISS      )
            ENDIF
*
            RETURN
         END IF
 4100 CONTINUE
*
      NHP  = LENC(HAXIS)
      HMSG = 'AXIS '''//HAXIS(1:NHP)//''' IS NOT DEFINED.'
      CALL MSGDMP( 'W', 'GUAIAX', HMSG )
*
      RETURN
*=======================================================================
*"         << 内部設定格子の設定参照 >>
*====================================================================== 
      ENTRY GUQIAN
     O    ( IAMAX )
*
      IAMAX = 0
      DO 5100 IA = NAXIS, 1, -1
         IF ( HAXISA( IA ) .NE. ' ' ) THEN
            IAMAX = IA
            RETURN
         ENDIF
 5100 CONTINUE
*
      RETURN
*=======================================================================
*"         << 内部設定格子の出力 >>
*====================================================================== 
      ENTRY GUWIAX
     I         ( HHEAD )
*
      DO 6100 IA = 1, NAXIS
         CALL GHCGET( HHEAD, 'AITM1', HAITM )
         IF ( HAITM .NE. HAXISA( IA ) ) THEN
            CALL GHCGET( HHEAD, 'AITM2', HAITM )
            IF ( HAITM .NE. HAXISA( IA ) ) THEN
               CALL GHCGET( HHEAD, 'AITM3', HAITM )
               IF ( HAITM .NE. HAXISA( IA ) ) THEN
                  GOTO 6100
               ENDIF
            ENDIF
         ENDIF
         IF ( HAXISA( IA ) .EQ. ' ' ) GOTO 6100
*
         CALL GTPGET( 'WFILE', IFILW )
         CALL GTCGET( 'FAXLOC1', HAXF  )
         NHF   = LENC( HAXF )
         HFILE = HAXF(1:NHF)//HAXISA( IA )
*
         CALL GFWOPN
     M         ( IFILW ,
     I           HFILE   )
         CALL GFWRIT
     O         ( HHEADA(1,IA), AXLOCA(1,IA),
     I           IFILW , 1   , 0             )
         CALL GFCLSE ( IFILW )
*
         CALL GTCGET( 'FAXWGT1', HAXF  )
         NHF   = LENC( HAXF )
         HFILE = HAXF(1:NHF)//HAXISA( IA )
*
         CALL GFWOPN
     M         ( IFILW ,
     I           HFILE   )
         CALL GFWRIT
     O         ( HHEADA(1,IA), AXWGTA(1,IA),
     I           IFILW , 1   , 0             )
         CALL GFCLSE ( IFILW )
*
 6100 CONTINUE
*
      RETURN
      END
************************************************************************
*"         << 内部設定格子座標の付加設定(2) >>
************************************************************************
      SUBROUTINE GUAIAH
     I         ( HHEAD , ID    ,
     I           AXLOC1, AXWGT1,
     I           IZ                      )
*
      CHARACTER  HHEAD ( * )*(*)         !" ヘッダー
      INTEGER    ID                      !" 何次元目の軸か
      REAL       AXLOC1                  !" 位置
      REAL       AXWGT1                  !" 重み
      INTEGER    IZ                      !" 格子番号
*
#ifdef SYS_IBMS
      INCLUDE    (GZSIZE)                !" NCC, NDC
#else
#include         "gzsize.F"              !" NCC, NDC
#endif
      CHARACTER  HAXIS *(NCC)            !" 格子識別名称
      CHARACTER  HP    *(NCC)            !" パラメータ名称
*
      IF ( ( ID .LT. 1 ) .OR. ( ID .GT. 3 ) ) THEN
         CALL MSGDMP( 'W', 'GUAIAH', 'IRREGAL ID' )
         RETURN
      ENDIF
*
      HP      = 'AITM'
      WRITE ( HP(5:5), '(I1)' ) ID
      CALL GHCGET ( HHEAD, HP  , HAXIS )
*
      CALL       GUAIAX
     I         ( HAXIS , AXLOC1, AXWGT1,
     I           IZ                      )
*
      RETURN
      END
