ASMB,R,L,C
      NAM CSQRT,6 24998-1X090 REV.2013 791016 
      ENT CSQRT 
      EXT .ZRNT,.ENTP,CABS,SQRT,..FCM,.CFER 
*********************************************************************** 
*                                                                     * 
*     NAME: CSQRT                                                     * 
*   SOURCE: 24998-18090                                               * 
*    RELOC: PART OF 24998-12002                                       * 
*     PGMR: CRG                                                       * 
*                                                                     * 
*********************************************************************** 
*                                                                     * 
*     (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979.  ALL RIGHTS         * 
*     RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,          * 
*     REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT    * 
*     THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.           * 
*                                                                     * 
*********************************************************************** 
* 
*     COMPLEX SQUARE ROOT 
* 
*     CALLING SEQUENCE:   Y = CSQRT(X)
* 
*                         JSB CSQRT 
*                         DEF *+3 
*                         DEF Y 
*                         DEF X 
* 
*********************************************************************** 
* 
TDB   NOP 
      ABS CSQRT-TDB 
TDBP2 NOP 
ADIX  BSS 1 
ADIY  BSS 1 
SGNRX BSS 1 
TEMP  BSS 2 
Y     BSS 1 
X     BSS 1 
* 
CSQRT NOP           ENTRY POINT 
      JSB .ZRNT 
      DEF LIBX
      JSB .ENTP     GET ADDRESSES 
      DEF Y 
      STA TDBP2     SAVE RTN ADDR 
* 
*********************************************************************** 
      SKP 
*********************************************************************** 
* 
*     CALCULATE CABS(X) AND CHECK FOR X = 0 
* 
      JSB CABS      COMPLEX ABS VALUE OF X
      DEF *+2       RTN ADDR
      DEF X,I 
      DST TEMP      TEMP = CABS(X)
* 
      SZA,RSS       SKIP IF NOT ZERO
      JMP ZERO      ZERO, FINISH UP 
* 
*********************************************************************** 
* 
*     CALCULATE REAL(Y) 
* 
      DLD X,I       GET RX
      STA SGNRX     SGNRX = SIGN(RX)
* 
      SSA           SKIP IF RX > 0
      JSB ..FCM     ABS(RX) 
* 
      FAD TEMP      ABS(RX) + CABS(X) 
      FDV F2.0      (ABS(RX)+CABS(X))/2.0 
      JSB SQRT      TAKE SQUARE ROOT
      HLT 33B       NEVER ERROR RETURN
      DST Y,I       RY = SQRT((ABS(RX)+CABS(X))/2.0)
* 
      FAD A         TEMP = 2.0 * RY 
      DST TEMP
* 
*********************************************************************** 
* 
*     CALCULATE ADDRESSES OF IMAG(X) AND IMAG(Y)
* 
      LDA X 
      ADA .2
      STA ADIX      ADIX = ADDR(IX) 
* 
      LDB Y 
      ADB .2
      STB ADIY      ADIY = ADDR(IY) 
* 
*********************************************************************** 
      SKP 
*********************************************************************** 
* 
*     CALCULATE IMAG(Y) 
* 
      DLD ADIX,I    GET IX
      FDV TEMP
      DST ADIY,I    IY = IX / (2.0 * RY)
      DST TEMP      TEMP = IY 
* 
*********************************************************************** 
* 
*     TEST FOR REAL(X) > 0
* 
      LDB SGNRX     RX < 0 ?
      SSB,RSS       SKIP IF RX < 0
      JMP LIBX      RX > 0, DONE
* 
************************************************************************
* 
*     REAL(X) < 0, SO SWAP REAL(Y) AND IMAG(Y)
* 
*     ALSO, IF IMAG(X) < 0, COMPLEMENT Y
* 
      SSA           IX < 0 ?
      JMP NEG       JUMP IF IX < 0
* 
      DLD Y,I       SWAP RY AND IY
      DST ADIY,I
      DLD TEMP
      DST Y,I 
      JMP LIBX      DONE
* 
************************************************************************* 
      SKP 
************************************************************************* 
* 
*     COMPLEMENT AND SWAP REAL(Y) AND IMAG(Y) 
* 
NEG   DLD Y,I 
      JSB ..FCM     -RY 
      DST ADIY,I
      DLD TEMP
      JSB ..FCM     -IY 
      DST Y,I 
* 
************************************************************************* 
* 
LIBX  JMP TDBP2,I   RETURN
      DEF TDB 
      DEC 0 
* 
************************************************************************* 
* 
ZERO  JSB .CFER 
      DEF Y,I 
      DEF X,I 
      JMP LIBX      EXIT
* 
************************************************************************
* 
A     EQU 0 
F2.0  DEC 2.0 
.2    DEC 2 
* 
*********************************************************************** 
      END 
                                                                